{$i-}
{$ifndef modif}{$i modif.inc}{$endif}
{$define ilasm}
unit FTgr;
interface
uses pictures,toolsb,chanels,dos,pointers;


{savers of images}
Function SavePictureFtG(var p:picture;AlineProc:PAbstractLineProc):Boolean;

{loaders of images}
Function LoadPictureART(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureBMP(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureCUT(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureFtG(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureGIF(var obr:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureHRZ(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureICO(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureMAC(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureMAT(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureOKO(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPicturePBM(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPicturePCX(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPicturePNG(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPicturePS(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureRAS(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureRAS_Danger(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureSUNRAS(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureTGA(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureTIF(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureTXT(var p:picture;AlineProc:PAbstractLineProc):integer;
Function LoadPictureWPG(var p:picture;AlineProc:PAbstractLineProc):integer;


{other userful tools}
Procedure ReMapPalette(var obr:picture);
Procedure Bin2Gray(var obr:picture);
Procedure Gray2Bin(var obr:picture);


Procedure SetBinPix(x:word;p:pointer);
Procedure ReSetBinPix(x:word;p:pointer);
Function GetBinPix(x:word;p:pointer):Byte;


{Header struct definitions}
Type FtGrHeader=record
	identific:array [1..4] of char;
	ver:	word;
	end;
     FtGrObject=record
	typ:	byte;
	size:	longint;
	end;
{Definovan‚ objekty:0 - pr zdn˜ objekt
		    1 - textov˜ koment ©
		    2 - zvukov˜ koment ©
		    3 - ikona
		    4 - obr zek (rastrov˜)
		    5 - velk˜ obr zek (rastrov˜)
		    6 - ikona (vektorov )
		    7 - obr zek (vektorov˜)
		    8 - velk˜ obr zek (vektorov˜)

Podtypy:	   20 - paleta
		   21 - sou©adnice p©esn‚ho um¡stˆn¡
		   22 - pomocn‚ informace

Speci ln¡ typy	  100 - kontejner (adres ©)}

     FtgrPalette=record
	items:	   word;
	typ:	   byte; {2-word Packed; 3-24 bits; 6-word for R,G,B}
	startItem: word;
	destPlanes:byte;
	end;
     FtgrImage=record
	rows:	Word;
	cols:	Word;
	planes:	Byte;
	interpretation:Byte;
	compression:Byte;
	end;





const Inside_Gray	=  0;
      Inside_RGB	= 10;
      Inside_Palette	= 20;

      SchMask = $7;
      Schless_2d   = 1;
      Schless_3d   = 2;
      Schless_3Dvar= 3;
      Hufmask = $18;
      Huff    =  8;
      HuffVar = $10;
      RemapPal= $20;
      GrayCode= $40;
      StringDetect=$80;
      FtGrCompression:Byte=Schless_3DVar+ HuffVar {+ GrayCode+RemapPal}; {type of compression}


      CBufSize=4096;{1024;}
      ProbeCells=10;

      Hu2Sizes:array[0..7] of word = (8,16,32,64,128,256,512,1024); {sizes of Huffman encoded area}
      Hu2prefix:array[0..7] of byte= (3, 4, 5, 6,  7,  8,  9,  10);

      Repeaters:array[2..7] of shortint = (3,7,15,31,63,127);
      ZeroValues:array[2..7] of shortint =(2,6,14,30,62,126);

      Aditors:   array[2..7] of shortint = (1,3, 7,15,31, 63);



type pByte=^Byte;
     pWord=^Word;
     pfile=^File;
     pBitStream=^BitStream;
     ReadFromFileBitProc=procedure(b:PBitStream);

     BitStream=record
	ptr:pByte;
	RealBufStart,BufEnd:pByte;
	bitbuf:longint;
	bufSize:Word;
	bitpos:Byte;

	fileleft:Longint;
	f:Pfile;
	FileProc:ReadFromFileBitProc;
	flag:byte;


	_BufEnd:Word;
	m:Byte;
	n:Word;
	end;


Procedure InitBitStream(var b:bitstream;p:pointer;BufSize:Word;f:Pfile;fsiz:longint);
Function readnBits(var b:bitstream;n:integer;var param):Word;
Function Read_n(var b:bitstream;n:Byte):Word;



implementation
(*
{$ifdef windows}
{uses wincrt; {!!!!!!!!!!!!!!!!!!!!!!}
{$else windows}
{$ifdef crtx}crtx;{$else}crt;{$endif} {Crt tu nebude!!!!!!!!!!!!!!!!!!!!!!}
{$endif windows}
*)

const MaxHItems=1024;
Type THistCount=longint;
     PHistCount=^THistCount;
     Ahuf=array[-2..MaxHItems] of THistCount;
     AhufMv=array[0..MaxHItems] of THistCount;
     hrec=record
	  size:ShortInt;
	  number:Word;
	  code:longint;
	 end;
     Bhuf=array[0..MaxHItems] of hrec;
     Chuf=array[0..35] of longint;


    TSmaskFull=array [0..256] of byte;
    tnums=set of 0..15;
    TSmask1d=set of 0..1;



Procedure SetBinPix(x:word;p:pointer); {This procedure set one bit in the bit array}
var b:^byte absolute p;
begin
 inc(b,x shr 3);
{ b^:=b^ or ($80 shr(x and $7));{}
 b^:=b^ or (1 shl (x and $7));{}
end;


Procedure ReSetBinPix(x:word;p:pointer); {This procedure clear one bit in the bit array}
var b:^byte absolute p;
begin
 inc(b,x shr 3);
{b^:=b^ and not($80 shr(x and $7));}
 b^:=b^ and not(1 shl(x and $7));
end;

{$ifdef	ilasm}				{This procedure read one bit in the bit array}
Function GetBinPix(x:word;p:pointer):Byte;	assembler;
asm
	les	si,p
	mov	ax,x
	mov	cx,ax

	shr	ax,3
	add	si,ax

	mov	ax,1	;{ah=0}
	and	cl,7	
	shl	al,cl	;{and mask}

	and 	al,byte ptr es:si
end;

{$else}
Function GetBinPix(x:word;p:pointer):Byte;
var b:^byte absolute p;
    a:byte;
begin
 inc(b,x shr 3);
{GetBinPix:=b^ and ($80 shr(x and $7));{}
 GetBinPix:=b^ and (1 shl(x and $7));{}
end;
{$endif}


Procedure WriteMask(soubor:string;items:word;p:pointer);
var txt:text;
    i:word;
begin
assign(txt,soubor);
rewrite(txt);
for i:=0 to items-1 do
	begin
	if GetBinPix(i,p)>0 then writeln(txt,i,' :',1)
			    else writeln(txt,i,' :',0);
	end;
close(txt);
end;


Function SizeNum(n:word):Word; {This procedure return a size of the number coded in exp code}
begin
 SizeNum:=2;
 if n<=2 then exit;
 SizeNum:=3;
 if n<=4 then exit;
 SizeNum:=5;
 if n<=8 then exit;
 SizeNum:=7;
 if n<=16 then exit;
 SizeNum:=9;
 if n<=32 then exit;
 SizeNum:=11;
 if n<=64 then exit;
 SizeNum:=13;
 if n<=128 then exit;
 SizeNum:=15;
 if n<=256 then exit;
 SizeNum:=17;
 if n<=512 then exit;
 SizeNum:=19;
 if n<=1024 then exit;
 SizeNum:=21;

end;

{This procedure read file and fill the bitstream buffer}
Procedure ReadFromFileBit(b:PBitStream); far;
var ReadedB:word;
begin

 ReadedB:=b^.BufSize;
 if(ReadedB>b^.FileLeft) then ReadedB:=b^.FileLeft;

 BlockRead(b^.f^,b^.RealBufStart^,ReadedB,ReadedB);
 dec(b^.FileLeft,ReadedB);
 if(ReadedB=0) then b^.FileLeft:=0;		{EOF}
 b^.ptr:=b^.realBufStart;
 b^.BufEnd:=b^.realBufStart;
 inc(b^.BufEnd,ReadedB);
end;


{This procedure write bitstream  buffer to disk}
Procedure WriteToFileBit(var b:bitstream);
var s2,size:Word;
    pp2:pointer;
begin
  size:=word(b.ptr)-word(b.RealBufStart)+1;
  if b.m=0 then dec(size);
  b.ptr:=b.RealBufStart;
  if b.FileLeft<0 then
	begin
	exit;
	end;

  BlockWrite(b.f^,b.ptr^,Size,S2);
  b.m:=$01;
  b.ptr^:=0;
  inc(b.FileLeft,Size);
  if (Size<>S2)or(IOResult<>0) then b.FileLeft:=-1; {error}
end;

{This procedure make initialization of the bit stream}
Procedure InitBitStream(var b:bitstream;p:pointer;BufSize:Word;f:Pfile;fsiz:longint);
begin
{----------------------}
 b.m:=$01;
 b._BufEnd:=word(p)+BufSize-1;

 b.n:=0;
{---------------------}


 b.FileLeft:=fsiz;
 b.bufSize:=Bufsize and not(word(1));
 b.RealBufStart:=p;
 b.ptr:=p;
 b.RealBufStart^:=0;
 b.BufEnd:=b.realBufStart;
 b.bitpos:=32;
 b.flag:=0;

 b.f:=f;
 b.fileproc:=ReadFromFileBit;
end;

{This procedure read n bits from the bit stream}
Function Read_n(var b:bitstream;n:byte):Word;
const bmsk:array[0..16] of word=
   ($0,$1,$3,$7,$F,$1F,$3F,$7F,$FF,
    $1FF,$3FF,$7FF,$FFF,$1FFF,$3FFF,$7FFF,$FFFF);

var u:Word;
begin
 if b.bitPos>=16 then
	begin
	b.BitBuf:=b.BitBuf shr 16;
	dec(b.bitPos,16);
	if(word(b.ptr)>=word(b.BufEnd)) then b.fileproc(@b);
	b.BitBuf:=b.BitBuf or ( longint(pWord(b.ptr)^) shl 16 );
	inc(b.ptr,2);
	end;
 u:=b.BitBuf shr b.BitPos;
 inc(b.BitPos,n);
 Read_n:=u and bmsk[n];
end;

{ read unlimited number of bits from bitstream *pbits }
Function readnBits(var b:bitstream;n:integer;var param):Word;
var ptrb:^byte;
begin
 ptrb:=addr(param);
 while(n>=8) do
	begin
	ptrb^:=Read_n(b,8);
	inc(ptrb);
	dec(n,8);
	end;
 if(n>0) then ptrb^:=Read_n(b,n);
end;



Procedure WriteBit(var b:bitstream;x:Boolean); {This procedure write one bit to the bit stream}
var a: integer;
begin
if x then b.ptr^:=b.ptr^ or b.m;

b.m:=b.m shl 1;
if(b.m=0) then
	begin
	inc(b.ptr);
	if word(b.ptr)>b._BufEnd then
		begin
		WriteToFileBit(b);
		end;
	inc(b.n);
	b.ptr^:=0;
	b.m:=$01;
	end;
end;


Procedure writenBits(var b:bitstream;n:Word;const param); {This procedure write n bits to the bit stream}
var a:byte;
    ptrb:^byte;
begin
if n=0 then exit;
ptrb:=addr(param);

a:=1;
while(n>0) do
	begin
	WriteBit(b,(ptrb^ and a)<>0);
	if a=128 then
		begin
		a:=1;
		inc(ptrb);
		end
		else a:=a shl 1;
	dec(n);
	end;
end;


{This procedure write number to the bit stream}
Procedure WriteNumber(var b:bitstream;x:longint);
var i:word;
    a:longint;
begin
if x=0 then exit;
dec(x);
if x<2 then
	begin
	x:=x shl 1;
	writenBits(b,2,x);
	exit;
	end;
i:=0;
a:=x;
while a>0 do
	begin
	a:=a shr 1;
	inc(i);
	end;

a:=$FFFFFFFF;
writenBits(b,i-1,a);
WriteBit(b,False);
writenBits(b,i-1,x);
end;

{This procedure chages bit order eg: bits 1234 -> 4321}
Function Prohod(i:longint;li:word):longint;		assembler;
asm
db 66h;	mov	bx,word ptr i
	mov	cx,li
db 66h;	xor	ax,ax
@otoc:
db 66h; shr	bx,1
db 66h;	rcl	ax,1
	loop	@otoc
db 66h; mov	dx,ax
db 66h; shr	dx,16
end;



{This procedure read number from the bitstream}
Function ReadNumber(var b:bitstream):longint;
const exchange:array[0..3] of byte = (0,2,1,3);
var i:word;
    n:longint;
begin
i:=exchange[Read_n(b,2)];
if i<2 then		{i=0,1}
	begin
	ReadNumber:=i+1;	{0,1 --> 1,2}
	exit;
	end;
dec(i);
if i=2 then
       begin
       i:=2;
       while Read_n(b,1)<>0 do inc(i);
       end;

n:=0;
readnBits(b,i,n);
ReadNumber:=(longint(1) shl i) + n + 1;
end;

{--------------Procedures for removing strings-------------}
type Pretezec=^Tretezec;
     Tretezec=record
	next:Pretezec;
	x,y:word;
	length:word;
	data:Pbyte;
	end;

     pointB=record
	x,y:shortint;
	NxD:byte;
	end;
     okoli=array[1..8] of pointB;

const h:array[0..8] of okoli=
{		1		  2 		      3		     4  		   5		    6		     7		   8}
{smer 0}(((x:1 ;y:0;Nxd:1),(x: 1;y: 1;Nxd:2),(x: 0;y: 1;Nxd:3),(x:-1;y:1;Nxd:4),
										 (x:-1;y: 0;Nxd:5),(x:-1;y:-1;Nxd:6),(x: 0;y:-1;Nxd:7 ),(x: 1;y:-1;Nxd:8)),
{smer 1} ((x:1 ;y:0;Nxd:1),(x: 1;y: 1;Nxd:2),(x: 1;y:-1;Nxd:8),(x: 2;y:0;Nxd:1),
										 (x: 0;y: 1;Nxd:3),(x: 0;y:-1;Nxd:7),(x: 2;y: 1;Nxd:2),(x: 2;y:-1;Nxd:8)),
{smer 2} ((x:1 ;y:1;Nxd:2),(x: 1;y: 0;Nxd:1),(x: 0;y: 1;Nxd:3),(x: 2;y:2;Nxd:2),
										 (x: 1;y:-1;Nxd:8),(x:-1;y: 1;Nxd:4),(x: 2;y: 1;Nxd:2),(x: 1;y:2;Nxd:2)),
{smer 3} ((x:0 ;y:1;Nxd:3),(x: 1;y: 1;Nxd:2),(x:-1;y: 1;Nxd:4),(x:1 ;y:0;Nxd:1),
										 (x:-1;y:0;Nxd:5), (x:0 ;y: 2;Nxd:3),(x: 1;y: 2;Nxd:2),(x:-1;y:2;Nxd:4)),
{smer 4} ((x:-1;y:1;Nxd:4),(x:0 ;y: 1;Nxd:3),(x:-1;y: 0;Nxd:5),(x: 1;y: 1;Nxd:2),
										 (x:-1;y:-1;Nxd:6),(x:-2;y: 2;Nxd:4),(x:-1;y: 2;Nxd:4),(x:-2;y: 1;Nxd:4)),
{smer 5} ((x:-1;y:0;Nxd:5),(x:-1;y: 1;Nxd:4),(x:-1;y:-1;Nxd:6),(x: 0;y: 1;Nxd:3),
										 (x: 0;y:-1;Nxd:7),(x:-2;y: 0;Nxd:5),(x:-2;y: 1;Nxd:4),(x:-2;y:-1;Nxd:6)),
{smer 6} ((x:-1;y:-1;Nxd:6),(x: 0;y:-1;Nxd:7),(x:-1;y: 0;Nxd:5),(x:-1;y:1;Nxd:4),
										 (x: 1;y:-1;Nxd:8),(x:-2;y:-2;Nxd:6),(x:-1;y:-2;Nxd:6),(x:-2;y:-1;Nxd:6)),
{smer 7} ((x: 0;y:-1;Nxd:7),(x:-1;y:-1;Nxd:6),(x: 1;y:-1;Nxd:8),(x:1 ;y:0;Nxd:1),
										 (x:-1;y: 0;Nxd:5),(x: 0;y:-2;Nxd:7),(x:-1;y:-2;Nxd:6),(x: 1;y:-2;Nxd:8)),
{smer 8} ((x: 1;y:-1;Nxd:8),(x:1 ;y:0;Nxd:1),(x: 0;y:-1;Nxd:7),(x: 1;y: 1;Nxd:2),
										 (x:-1;y:-1;Nxd:6),(x: 2;y:-2;Nxd:8),(x: 1;y:-2;Nxd:8),(x: 2;y:-1;Nxd:8)));

Function CompareStr(x1,x2:Pointer):Boolean; far;
var TStr1:Pretezec absolute x1;
    TStr2:Pretezec absolute x2;
begin
CompareStr:=
  longint(TStr1^.y)*65536+TStr1^.x<longint(Tstr2^.y)*65536+Tstr2^.x
end;


Procedure Put_PixString(var p:picture;xs,ys:word;length:word;b:Pbyte);
var d:byte;

begin
d:=0;
SetPixel(p,xs,ys,1);
while length>1 do
	  begin
	  xs:=xs+h[d,b^].x;
	  ys:=ys+h[d,b^].y;
	  d:=h[d,b^].NxD;
	  SetPixel(p,xs,ys,1);

	  dec(Length);
	  inc(b);
	  end;

end;


Procedure PutAllStrings(var p:picture; var retezceK:Pretezec;RealPut:Boolean);
var TempRetezec:Pretezec;
begin
while retezceK<>nil do
	begin
	if RealPut then
	  Put_PixString(p,retezceK^.x,retezceK^.y,retezceK^.Length,retezceK^.data);
	freemem(retezceK^.data,retezceK^.Length);
	TempRetezec:=retezceK;
	retezceK:=retezceK^.next;
	dispose(TempRetezec);
	end;
end;


Procedure Nalezni_retezce(var p:picture; var retezceK:Pretezec);
type pointW=record
	x,y:word;
	end;
const maxBuf=500;

var d:byte;
    i,x,y,x1,y1:word;
    length,breakLength,lengthAll:longint;
    Retezcu:longint;
    txt:text;

    buf:array[0..MaxBuf] of byte;
    buf2:array[0..MaxBuf] of pointW;
    NewRetezec:Pretezec;

    Procedure UnloadStr(x,y:word);
    label ContLine;
    var i:word;
	x2,y2:word;
    begin
	 d:=0;
	 length:=0;
	 Breaklength:=0;
	 x1:=x;
	 y1:=y;

{		fillchar(buf2,sizeof(buf2),0);
	 fillchar(buf,sizeof(buf),0);}


	 while (pixel(p,x1,y1)<>0) do
		 begin
		 if Length>=MaxBuf Then break;
		 setpixel(p,x1,y1,0);
		 buf2[Length].x:=x1;
		 buf2[Length].y:=y1;

		 inc(length);

contLine:        for i:=1 to 8 do
		   begin
{			  putpixel(x1+h[d,i].x,y1+h[d,i].y,brown);{}

		   x2:=x1+h[d,i].x;
		   y2:=y1+h[d,i].y;
		   if pixel(p,x2,y2)<>0 then
			 begin
			 if (x2>=p.x)or(y2>=p.y) then continue;

			 buf[length-1]:=i;
			 x1:=x2;
			 y1:=y2;
			 d:=h[d,i].NxD;
			 break;
			 end;
		   end;
		 end;

    end;

var NormalLength:Word;
    x2,y2:word;
    okoli:Byte;

begin
{assign(txt,'i:\pokus.txt');
append(txt);
if IOResult<>0 then
	rewrite(txt);
writeln(txt,'-------------------------------');
view(p);readkeyex;{}

lengthAll:=0;
Retezcu:=0;
for y:=0 to p.y-1 do
   for x:=0 to p.x-1 do
	begin
	if pixel(p,x,y)<>0 then
	   begin
	   okoli:=0;
	   if pixel(p,x+1,y)<>0   then okoli:=okoli or 1;
	   if pixel(p,x+1,y+1)<>0 then okoli:=okoli or 2;
	   if pixel(p,x,y+1)<>0   then okoli:=okoli or 4;
	   if pixel(p,x-1,y+1)<>0 then okoli:=okoli or 8;
	   if pixel(p,x-1,y)<>0   then okoli:=okoli or 16;
	   if pixel(p,x-1,y-1)<>0 then okoli:=okoli or 32;
	   if pixel(p,x,y-1)<>0   then okoli:=okoli or 64;
	   if pixel(p,x+1,y-1)<>0 then okoli:=okoli or 128;

	   if okoli in [1,2,4,8,16,32,64,128] then {}
		begin

		x2:=x;y2:=y;
		UnloadStr(x2,y2);
		NormalLength:=Length;

		Put_PixString(p,x2,y2,Length,addr(buf));

		x2:=x1;y2:=y1;
		UnloadStr(x2,y2);

		if length<NormalLength then
			begin
			Put_PixString(p,x2,y2,Length,addr(buf));

			x2:=x;y2:=y;
			UnloadStr(x2,y2);
			if NormalLength<>Length then
				asm int 3; end; {data was changed!!!!}
			end;

(**)

		if Length<=25 then Put_PixString(p,x2,y2,Length,addr(buf))
			else begin
			     New(NewRetezec);
			     getmem(NewRetezec^.data,Length);
			     move(buf,NewRetezec^.data^,Length);
			     NewRetezec^.Next:=RetezceK;
			     NewRetezec^.x:=x2;
			     NewRetezec^.y:=y2;
			     NewRetezec^.Length:=Length;
			     RetezceK:=NewRetezec;

{			     writeln(txt,'x=',x2,' y=',y2,' length=',length,':',BreakLength);{}
			     inc(LengthAll,length);
			     inc(retezcu);
			     end;
		end;
	     end;
	end;

if RetezceK<>nil then SortPtr(RetezceK,CompareStr);

{PutAllStrings(p,retezceK,True);}
end;




{----------End of procedures for removing strings-----------}

{-----------Procedures for Huffman coding----------}

{This procedure read hufman encoded number from the bitstream}
Function ReadHufNum(var b:bitstream;const bha:Bhuf;const cha:Chuf;HprPos:Byte;HuffOffset:Byte):longint;
var i:word;
    x,q,n:longint;
begin
i:=0;
q:=0;

repeat
   repeat
   q:=(q shl 1)+read_n(b,1);
   inc(i);

   until cha[i]<>-1;


x:=bha[cha[i]].code-q;			{!!!!Error!!!!}
until x>=0;

n:=bha[cha[i]-x].number;
if n<>HuffOffset then
	begin
	ReadHufNum:=n-HuffOffset;
	exit;
	end;


i:=HprPos;
while Read_n(b,1)<>0 do inc(i);
n:=0;
readnBits(b,i,n);
ReadHufNum:=(longint(1) shl i) + n + 1;
end;

{This procedure writes to the bitstream huffmam encoded number}
Procedure WriteHufNum(var b:bitstream;const Huf:bhuf;x:longint;HufIdx:Byte;HprPos:Byte);
var i:word;
    a:longint;
begin
if x=0 then exit;

if x<=Hu2Sizes[HufIdx] then
	begin
	writeNbits(b,Huf[x+HprPos].size,Huf[x+HprPos].code);
	exit;
	end;

writeNbits(b,Huf[HprPos].size,Huf[HprPos].code);
dec(x);
i:=0;
a:=x;
while a>0 do
	begin
	a:=a shr 1;
	inc(i);
	end;

a:=$FFFFFFFF;
writenBits(b,i-1-Hu2Prefix[HufIdx],a);
WriteBit(b,False);
writenBits(b,i-1,x);
end;
{*****************}

{This procedure compute huffman code from known histogram}
Procedure Huffman(aAHuf:PHistCount;var b:Bhuf;Hitems:Word);
type fArray=array[0..MaxHItems] of word;
     PfArray=^fArray;
     Hufstruct=record
	value:longint;
	NumDat:word;
	data:PfArray;
	end;
     HufArray=record
	number:Word;
	a:array[0..MaxHItems] of HufStruct;
	end;


var a:^AhufMv absolute aAhuf;
    HufRec:^HufArray;
    Hr:HufStruct;
    i,j,k:Word;

    Procedure InsSort(H:HufStruct);
    var i:Word;
    begin
    i:=HufRec^.number;
    if i>0 then
      while (HufRec^.a[i-1].Value<H.Value) do
	begin
	HufRec^.a[i]:=HufRec^.a[i-1];
	dec(i);
	if i=0 then break;
	end;
    HufRec^.a[i]:=H;
    inc(HufRec^.number);
    end;

begin
new(Hufrec);
fillchar(HufRec^,sizeof(Hufrec^),0);

for i:=0 to HItems do      	{zarazovani novych polozek}
  if a^[i]<>0 then
	begin
	Hr.value:=a^[i];
	Hr.NumDat:=i;
	Hr.Data:=nil;
	InsSort(Hr);
	end;
for i:=0 to HufRec^.Number-1 do {alokace pameti}
	begin
	getmem(HufRec^.a[i].data,Sizeof(Word));
	HufRec^.a[i].data^[0]:=HufRec^.a[i].NumDat;
	HufRec^.a[i].NumDat:=1;
	end;

fillchar(b,sizeof(b),0);

while HufRec^.Number>=2 do	{Huffmanova redukce}
	begin
	k:=HufRec^.Number-2;

	Hr.value:= HufRec^.a[k].Value+HufRec^.a[k+1].Value;
	Hr.numdat:=HufRec^.a[k].NumDat+HufRec^.a[k+1].NumDat;
	getmem(Hr.data,Hr.numdat*Sizeof(Word));
	for i:=0 to HufRec^.a[k].NumDat-1 do
		begin
		Hr.data^[i]:=HufRec^.a[k].Data^[i];
		inc(b[Hr.data^[i]].size);
		end;
	j:=HufRec^.a[k].NumDat;
	for i:=0 to HufRec^.a[k+1].NumDat-1 do
		begin
		Hr.data^[i+j]:=HufRec^.a[k+1].Data^[i];
		inc(b[Hr.data^[i+j]].size);
		end;


	dec(HufRec^.Number,2);
	freemem(HufRec^.a[k].data,HufRec^.a[k].NumDat*Sizeof(Word));
	HufRec^.a[k].NumDat:=0;
	HufRec^.a[k].Data:=nil;
	freemem(HufRec^.a[k+1].data,HufRec^.a[k+1].NumDat*Sizeof(Word));
	HufRec^.a[k+1].NumDat:=0;
	HufRec^.a[k+1].Data:=nil;

	InsSort(Hr);
	end;


for i:=0 to HufRec^.Number-1 do
	begin
	freemem(HufRec^.a[i].data,HufRec^.a[i].NumDat*Sizeof(Word));
	HufRec^.a[i].NumDat:=0;
	HufRec^.a[i].Data:=nil;
	end;
for i:=0 to HItems do b[i].Number:=i;
dispose(HUfrec);
end;

{Sorting histogram by sizes - used for huffman coding}
Procedure SortSize(var b:Bhuf;var c:chuf;Hitems:Word);
var x,y:integer;
    huhu:hrec;
begin
 for x:=0 to Hitems do	{sort}
	for y:=0 to Hitems-x-1 do
		if b[y].size>b[y+1].size then
			begin
			huhu:=b[y+1];
			b[y+1]:=b[y];
			b[y]:=huhu;
			end;

 fillchar(c,sizeof(c),$FF);
 for x:=0 to Hitems do
	c[b[x].size]:=x; {positions}
end;

{Sorting histogram by order - used for huffman coding}
Procedure SortNum(var b:Bhuf;Hitems:Word);
var x,y:integer;
    huhu:hrec;
begin
 for x:=0 to Hitems-1 do	{sort}
	while b[x].number<>x do
		begin
		y:=b[x].number;

		huhu:=b[x];
		b[x]:=b[y];
		b[y]:=huhu;
		end;
end;


{This procedure evaluates huffman codes}
Function HufCount_(var b:Bhuf;HItems:Word):Boolean;
var i:word;
    x,y:longint;
    BitHistogram:array[0..16] of word;
begin
 fillchar(BitHistogram,sizeof(BitHistogram),0);

 for i:=0 to HItems do
   inc(BitHistogram[b[i].Size]);

 y:=0;
 BitHistogram[0]:=0;
 for i:=1 to 15 do
   begin
   x := BitHistogram[i];

   if(x<>0) then BitHistogram[i] := y;
   inc(y,x);
   y := y shl 1;
   end;

 HufCount_ := y=65536;

 for i:=0 to HItems do
   begin
   if b[i].Size=0 then
     b[i].code := 0
   else
     b[i].code := BitHistogram[b[i].Size];
   inc(BitHistogram[b[i].Size]);
   end

(*
 HufCount:=False;	{if y=0 then only one value to be coded- no need huffman}
 if y>0 then		{size of huffman code space}
	begin
	while odd(y) do	{check integrity}
		y:=y shr 1;
	HufCount:=y=0;
	end;
*)
end;	{return:Is closed Huffman space?}


{This procedure evaluates huffman codes}
Function HufCount(var b:Bhuf;const c:Chuf;HItems:Word):Boolean;
var x:word;
    y:longint;
begin
 y:=0;

 if c[0]=-1 then x:=0
	    else x:=c[0]+1;

 b[x].code:=y;
 inc(x);
 while x<=Hitems do
		begin
		inc(y);
		if b[x].size>b[x-1].size then
			y:=y shl (b[x].size-b[x-1].size);
		b[x].code:=y;
		inc(x);
		end;

 HufCount:=False;	{if y=0 then only one value to be coded- no need huffman}
 if y>0 then		{size of huffman code space}
	begin
	while odd(y) do	{check integrity}
		y:=y shr 1;
	HufCount:=y=0;
	end;
end;	{return:Is closed Huffman space?}


{this procedure is used for compression of the huffman description table
 prefixes - prefixes to skip}
Function PackSizes_(bit:pBitstream;var b:Bhuf;MaxItems:Word;prefixes:byte):Word;
var i,j:integer;
    x,Max,MaxDif,t,lastS:shortint;
    FinalSize:Word;
begin
FinalSize:=0;

lastS:=2;
Max:=b[0].size;
MaxDif:=0;
for i:=prefixes to MaxItems do
	begin
	t:=b[i].size;
	if t<>0 then
		begin
		if(abs(lastS-t))>MaxDif then MaxDif:=abs(lastS-t);
		lastS:=t;
		end;
	if t>Max then Max:=t;
	end;

t:=127;		{zatim neumim}
if max<=30 then t:= 2;  {primy kod 0..30 RLC 31}
if max<=14 then t:= 1;	{primy kod 0..14 RLC 15}
if max<= 6 then t:= 0;	{primy kod 0.. 6 RLC  7}

if (MaxDif<= 6)and(max>6) then t:=5;
if (MaxDif<= 2)		  then t:=4;

if t=127 then begin;PackSizes_:=0;exit;end; {neumim ulozit}


if(Bit<>nil) then WriteNBits(bit^,3,t);
inc(FinalSize,3);


i:=0;
Max:=t and 3 + 3;
if t>=4 then
     begin		{Store histogram diff accepted}
     LastS:=2;

     for i:=0 to prefixes-1 do
	begin
	if(Bit<>nil) then WriteNumber(bit^,b[i].size+1);
	inc(FinalSize,SizeNum(b[i].size+1));
	end;

     for i:=prefixes to MaxItems do
	begin
	x:=b[i].size;
	if x=0 then b[i].size:=ZeroValues[Max]
	       else begin
		    b[i].size:=x-LastS+Aditors[Max];
		    LastS:=x;
		    end;
	end;

     i:=prefixes;
     end;


LastS:=2;
while i<=MaxItems do	{Store histogram RLC; no diff in this place}
	begin
	x:=b[i].size;

	j:=i;
	if x=lastS then
		begin
		while ((b[j].size=lastS)and(j<=MaxItems)) do
			begin
			inc(j);
			end;
		end;


	if j-i>1 then	{komprese se vyplati pro opakovani >= 3x}
		 begin
		 if(Bit<>nil) then
			begin
			WriteNBits(bit^,Max,Repeaters[Max]);
			writeNumber(bit^,j-i-1);
			end;
		 inc(FinalSize,Max);
		 inc(FinalSize,SizeNum(j-i-1));
		 i:=j-1;
		 end
		else  (*:*)
		begin
		if(Bit<>nil) then WriteNBits(bit^,Max,x);
		inc(FinalSize,Max);
		end;

	lastS:=x;
	inc(i);
	end;


if t>=4 then	{inverse diff process}
     begin
     LastS:=2;
     for i:=prefixes to MaxItems do
	      begin
	      if b[i].size=ZeroValues[Max] then b[i].size:=0
		       else
		       begin
		       dec(b[i].size,Aditors[Max]);
		       b[i].size:=LastS+b[i].size;
		       LastS:=b[i].size;
		       end;
	      end;
     end;

PackSizes_:=FinalSize;
end;

{This procedure is used for decompression of the huffman description table}
Function UnPacKSizes(var bit:Bitstream;var b:Bhuf;MaxItems:Word;t:shortint;prefixes:byte):Boolean;
var i,j:integer;
    x,Vtyp,typ,lastS:shortint;

begin
UnPacKSizes:=True;
typ:=0;
ReadNBits(bit,3,typ);
i:=0;
j:=0;
if typ>=4 then
	begin
	while i<prefixes do
		begin
		b[i].Size:=ReadNumber(bit)-1;
		b[i].Number:=i;
		inc(i);
		end;
	end;
lastS:=2;

vtyp:=typ and 3 + 3;
while i<=MaxItems do
	 begin
	 b[i].Number:=i;

	 if j>0 then
	   begin
	   dec(j);
	   b[i].Size:=LastS;
	   inc(i);
	   continue;
	   end;

	 ReadNBits(bit,vtyp,b[i].Size);
	 if(b[i].Size=Repeaters[vtyp]) then
		   begin
		   b[i].Size:=LastS;
		   j:=ReadNumber(bit);
		   inc(i);
		   continue;
		   end;
	 lastS:=b[i].Size;
	 inc(i);
	 end;


if typ>=4 then
    begin
    lastS:=2;
    for i:=prefixes to MaxItems do
	      begin
	      if b[i].size=ZeroValues[Vtyp] then b[i].size:=0
		       else
		       begin
		       dec(b[i].size,Aditors[Vtyp]);
		       b[i].size:=LastS+b[i].size;
		       LastS:=b[i].size;
		       if LastS<0 then
				begin	{Data Error: Size must not be <0}
				UnPacKSizes:=False;
				exit;
				end;
		       end;
	      end;
    end;
end;



{-------Here start main part of coding algorithm--------}
{RLC Compression of the 1st row and 1st column}
Function Schless1d(var obr:picture;x,y,kx,ky:word;var S1:TSmask1d):Word;
var M:byte;
    i,Max:Word;
    a:array[0..3] of word;
    koutecku:Word;
begin
 if not(obr.Valid) or (obr.planes<>1) then exit;

 fillchar(a,sizeof(a),0);

 if Kx=0 then Max:=obr.y-2;
 if Ky=0 then Max:=obr.x-2;

 for i:=0 to Max do
	begin
	M:=  pixel(obr,x+(kx and i),y+(ky and i))+
	   2*pixel(obr,x+(kx and (i+1)),y+(ky and (i+1)));
	inc(a[M]);
	end;

 S1:=[];
 koutecku:=0;
 for i:=0 to 1 do
	if a[i+2]>a[i] then
		begin
		S1:=S1 + [i];
		inc(koutecku,a[i]);
		end
		else inc(koutecku,a[i+2]);

 for i:=Max downto 0 do
	begin
	M:=pixel(obr,x+(kx and i),y+(ky and i));

	if (M in S1)xor(pixel(obr,x+(kx and (i+1)),y+(ky and (i+1)))=1)
		then SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),1)
		else SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),0);
	end;

Schless1d:=koutecku;
end;

{RLC Decompression of the 1st row and 1st column}
Function DeSchless1d(var obr:picture;x,y,kx,ky:word;S1:TSmask1d):Word;
var M:Byte;
    Max:word;
    i:Word;
begin
 if Kx=0 then Max:=obr.y-2;
 if Ky=0 then Max:=obr.x-2;

 for i:=0 to Max do
	begin
	M:=pixel(obr,x+(kx and i),y+(ky and i));

	if (M in S1)xor(pixel(obr,x+(kx and (i+1)),y+(ky and (i+1)))=1)
		then SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),1)
		else SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),0);
	end;
end;




{Selecting neighbourhood planes for RGB}
Procedure Setn3n4forRGB(var obr:picture;n:byte;var n2plane,n3plane,n4plane:Byte);
type ReRGB24=array[1..24]of byte;
		{ ( 1, 2, 3, 4, 5, 6, 7, 8,   9,10,11,12,13,13,15,16,  17,18,19,20,21,22,23,24);}
const Re2:ReRGB24=( 2, 3, 4, 5, 6, 7, 8,16,  10,11,12,13,14,15,16,24,  18,19,20,21,22,23,24,255);
      Re3:ReRGB24=( 9,10,11,12,13,14,15,15,  11,12,13,14,15,16,22,23,  19,20,21,22,23,24,255,255);
      Re4:ReRGB24=(17,18,19,20,21,22,23,24,  17,18,19,20,21,22,23,22,  20,21,22,23,24,255,255,255);
begin
if (n>obr.planes)or(n<=0) then exit;
n2plane:=n+1;
n3plane:=n+2;
n4plane:=n+3;
if FtGrCompression and RemapPal <> 0 then
    begin
    if obr.planes=24 then	{True Color RGB mode}
	begin
	n2plane:=Re2[n];
	n3plane:=Re3[n];
	n4plane:=Re4[n];
{	asm int 3; end;}
	end;
   end;
if n2plane>obr.planes then n2plane:=255;
if n3plane>obr.planes then n3plane:=255;
if n4plane>obr.planes then n4plane:=255;
end;


{This procedure decompress packed description of the estimator}
Procedure ExplodeBitFlags(var numera:tnums;var SmaskF,SmaskEx:TsmaskFull);
var ri,i:word;

begin
  fillchar(SmaskEx,Sizeof(SmaskF),0);
  for i:=0 to 2047 do
	begin
	ri:=i;
	if 11 in numera then ri:= ((ri and $F000) shr 1) or (ri and $7FF);
	if 10 in numera then ri:= ((ri and $F800) shr 1) or (ri and $3FF);
	if  9 in numera then ri:= ((ri and $FC00) shr 1) or (ri and $1FF);
	if  8 in numera then ri:= ((ri and $FE00) shr 1) or (ri and $0FF);
	if  7 in numera then ri:= ((ri and $FF00) shr 1) or (ri and $07F);
	if  6 in numera then ri:= ((ri and $FF80) shr 1) or (ri and $03F);
	if  5 in numera then ri:= ((ri and $FFC0) shr 1) or (ri and $01F);
	if  4 in numera then ri:= ((ri and $FFE0) shr 1) or (ri and $00F);
	if  3 in numera then ri:= ((ri and $FFF0) shr 1) or (ri and $007);
	if  2 in numera then ri:= ((ri and $FFF8) shr 1) or (ri and $003);
	if  1 in numera then ri:= ((ri and $FFFC) shr 1) or (ri and $001);
	if  0 in numera then ri:= ((ri and $FFFE) shr 1);

	if GetBinPix(ri,addr(SmaskF))<>0 then SetBinPix(i,addr(SmaskEx));
	end;

end;

{This procedure compute an optimal estimator for the selected bit plane}
Function SchCount3d2x3a(var obr,planeX:Picture;n:byte;var numera:tnums;var SmaskF:TsmaskFull):Longint;
type OptArray=array[0..4095] of longint;
     pbyte=^byte;
var x,y:integer;
    mask:byte;
    i:integer;
    a:^OptArray;

    koutecku3f:longint;
    p0,p1,p2,p3,p4,p5,p6:pbyte;

    plane2a,plane2b,plane3,plane4:pbyte;
    lpl:word;

    qq:array[0..ProbeCells] of longint;
    lm,lg:longint;
    c,num:word;
    qplanes:byte;

    n2plane,n3plane,n4plane:Byte;

label repeatReduction;
begin
if ((n>obr.Planes)or(not(Obr.Valid))) then exit;

new(a);
lpl:=(Obr.x+7) div 8;
Getmem(plane2a,lpl);
Getmem(plane2b,lpl);
Getmem(plane3,lpl);
Getmem(plane4,lpl);

fillchar(plane2a^,lpl,0);
fillchar(plane2b^,lpl,0);
fillchar(plane3^,lpl,0);
fillchar(plane4^,lpl,0);

Setn3n4forRGB(obr,n,n2plane,n3plane,n4plane);

if n2plane<=obr.planes then Peel1Plane(Obr,0,n2plane,plane2a);

fillchar(a^,sizeof(a^),0);
for y:=0 to Obr.y-2 do		{hlavni radkova smycka}
	begin

	if n<obr.planes then
		begin
		p3:=plane2a;plane2a:=plane2b;plane2b:=p3;
		Peel1Plane(Obr,y+1,n2plane,plane2a);

		if n+1<obr.planes then
		     begin
		     Peel1Plane(Obr,y+1,n3plane,plane3);
		     if n+2<obr.planes then
			begin
			Peel1Plane(Obr,y+1,n4plane,plane4);
			end;
		     end;
		end;

	p2:=pointer(PlaneX.data^[y+1]);
	p1:=pointer(PlaneX.data^[y]);
	if y=0 then p0:=p1			{duplikace radku 0}
	       else p0:=pointer(PlaneX.data^[y-1]); {y-1 ??????}

	p3:=plane2b;
	p4:=plane2a;

	p5:=plane3;
	p6:=plane4;


	i:=0;
	if (p0^ and 128) <> 0 then inc(i,128);
	if (p1^ and 128) <> 0 then inc(i,512);
	if (p2^ and 128) <> 0 then inc(i,2048);
	if (p3^ and 128) <> 0 then inc(i,8);
	if (p4^ and 128) <> 0 then inc(i,32);

	mask:=64;
	for x:=0 to Obr.x-2 do
		begin
		i:= ((i shr 1)and $554);
		if (p0^ and mask)<>0 then i:=i or 128;
		if (p1^ and mask)<>0 then i:=i or 512;
		if (p2^ and mask)<>0 then i:=i or 2048;
		if (p3^ and mask)<>0 then i:=i or 8;
		if (p4^ and mask)<>0 then i:=i or 32;
		if (p5^ and mask)<>0 then i:=i or 2;
		if (p6^ and mask)<>0 then i:=i or 1;

		mask:=mask shr 1;
		if mask=0 then
			begin
			mask:=128;
			inc(p0);
			inc(p1);
			inc(p2);
			inc(p3);
			inc(p4);
			inc(p5);
			inc(p6);
			end;
		inc(a^[i]);
		end;
	end;



Freemem(plane2a,lpl);
Freemem(plane2b,lpl);
Freemem(plane3,lpl);
Freemem(plane4,lpl);

{-----------vypocty diskriminativnosti smeru---------}

qplanes:=11;
num:=1 shl qplanes;


if numera=[] then
   begin
   RepeatReduction:
   num:=1 shl qplanes;

   koutecku3f:=0;
   for i:=0 to num-1 do
	  if a^[i+num]>a^[i] then inc(koutecku3f,a^[i])
			   else inc(koutecku3f,a^[i+num]);

   fillchar(qq,sizeof(qq),0);
   for x:=0 to qplanes-1  do
     begin
     c:=1 shl x;

     for i:=0 to num-1 do
	  begin
	  lm:=a^[i]+a^[i xor c];
	  lg:=a^[i + num]+a^[(i xor c) + num];

	  if lm<lg then inc(qq[x],lm)
		   else inc(qq[x],lg);
	  end;
     end;

     x:=0;		{nejmene diskriminativni smer}
     lm:=0;
     for i:=qplanes-1 downto 0 do
	  begin
	  qq[i]:=(qq[i] shr 1) - koutecku3f;
	  if lm>=qq[i] then
		  begin
		  lm:=qq[i];
		  x:=i;
		  end;
	  end;

   { bitu tabulky }

     if (num > 2*qq[x])and(qplanes>=1) then
	  begin				{vyjmi i ty smer}
	  c:=1 shl x;

	  y:=0;
	  for i:=0 to (2 * num)-1 do
		  begin
		  if (i and c) <> 0 then continue;
		  a^[y]:=a^[i]+a^[i or c];
		  inc(y);
		  end;

	  for i:= 0 to 15 do
	       begin
	       if (i in numera)and(x>=i) then inc(x);
	       end;
	  numera:=numera+[x];
	  dec(qplanes);

	  goto RepeatReduction
	  end;
     end
     else begin
	  for x:=qplanes-1 downto 0 do
		begin
		num:=1 shl qplanes;
		if x in Numera then
			begin
			c:=1 shl x;

			y:=0;
			for i:=0 to (2 * num)-1 do
				begin
				if (i and c) <> 0 then continue;
				a^[y]:=a^[i]+a^[i or c];
				inc(y);
				end;
			dec(qplanes);
			end;
		end;
	  num:=1 shl qplanes;
	  end;

fillchar(SmaskF,Sizeof(SmaskF),0);
koutecku3f:=0;
for i:=0 to Num-1 do
	if a^[i+Num]>a^[i] then begin
			    SetBinPix(i,addr(SmaskF));
			    inc(koutecku3f,a^[i]);
			    end
		       else inc(koutecku3f,a^[i+Num]);

dispose(a);
SchCount3d2x3a:=koutecku3f;

{WriteMask('dbg_.txt',Num,addr(SmaskF));{}
end;

{This procedure compute an optimal estimator for the selected bit plane}
Function SchCount3d2x3a_(var obr,planeX:Picture;n:byte;var numera:tnums;var SmaskF:TsmaskFull):Longint;
type OptArray=array[0..2047] of longint;
     pbyte=^byte;
var x,y:integer;
    mask:byte;
    i:integer;
    a:^OptArray;

    koutecku3f:longint;
    p0,p1,p2,p3,p4,p5,p6:pbyte;

    plane2a,plane2b,plane3,plane4:pbyte;
    lpl:word;

    qq:array[0..ProbeCells] of longint;
    lm:longint;
    c,num:word;
    qplanes:byte;

    n2plane,n3plane,n4plane:Byte;

label repeatReduction;
begin
if ((n>obr.Planes)or(not(Obr.Valid))) then exit;

new(a);
lpl:=(Obr.x+7) div 8;
Getmem(plane2a,lpl);
Getmem(plane2b,lpl);
Getmem(plane3,lpl);
Getmem(plane4,lpl);

fillchar(plane2a^,lpl,0);
fillchar(plane2b^,lpl,0);
fillchar(plane3^,lpl,0);
fillchar(plane4^,lpl,0);

Setn3n4forRGB(obr,n,n2plane,n3plane,n4plane);

if n2plane<=obr.planes then Peel1Plane(Obr,0,n2plane,plane2a);

fillchar(a^,sizeof(a^),0);
for y:=0 to Obr.y-2 do		{hlavni radkova smycka}
	begin

	if n<obr.planes then
		begin
		p3:=plane2a;plane2a:=plane2b;plane2b:=p3;
		Peel1Plane(Obr,y+1,n2plane,plane2a);

		if n+1<obr.planes then
		     begin
		     Peel1Plane(Obr,y+1,n3plane,plane3);
		     if n+2<obr.planes then
			begin
			Peel1Plane(Obr,y+1,n4plane,plane4);
			end;
		     end;
		end;



	p2:=pointer(PlaneX.data^[y+1]);
	p1:=pointer(PlaneX.data^[y]);
	if y=0 then p0:=p1			{duplikace radku 0}
	       else p0:=pointer(PlaneX.data^[y]);


	p3:=plane2b;
	p4:=plane2a;

	p5:=plane3;
	p6:=plane4;


	i:=0;
	if (p0^ and 128) <> 0 then inc(i,128);
	if (p1^ and 128) <> 0 then inc(i,512);
	if (p2^ and 128) <> 0 then inc(i,2048);
	if (p3^ and 128) <> 0 then inc(i,8);
	if (p4^ and 128) <> 0 then inc(i,32);

	mask:=64;
	for x:=0 to Obr.x-2 do
		begin
		i:= ((i shr 1)and $554);
		if (p0^ and mask)<>0 then i:=i or 128;
		if (p1^ and mask)<>0 then i:=i or 512;
		if (p2^ and mask)<>0 then i:=i or 2048;
		if (p3^ and mask)<>0 then i:=i or 8;
		if (p4^ and mask)<>0 then i:=i or 32;
		if (p5^ and mask)<>0 then i:=i or 2;
		if (p6^ and mask)<>0 then i:=i or 1;

		mask:=mask shr 1;
		if mask=0 then
			begin
			mask:=128;
			inc(p0);
			inc(p1);
			inc(p2);
			inc(p3);
			inc(p4);
			inc(p5);
			inc(p6);
			end;

		if i<=2047 then inc(a^[i])
			   else dec(a^[i and $7FF]);
		end;
	end;



Freemem(plane2a,lpl);
Freemem(plane2b,lpl);
Freemem(plane3,lpl);
Freemem(plane4,lpl);
{-----------vypocty diskriminativnosti smeru---------}

qplanes:=11;
num:=1 shl qplanes;


if numera=[] then
   begin
   RepeatReduction:
   num:=1 shl qplanes;

   koutecku3f:=0;
   for i:=0 to num-1 do inc(koutecku3f,abs(a^[i]));
   koutecku3f:=(longint(obr.x)*obr.y- obr.x-obr.y+1 -koutecku3f) div 2;

   fillchar(qq,sizeof(qq),0);
   for x:=0 to qplanes-1  do
     begin
     c:=1 shl x;

     for i:=0 to num-1 do
	  begin
	  inc(qq[x],abs(a^[i]+a^[i xor c]));
	  end;
     end;

     x:=0;		{nejmene diskriminativni smer}
     lm:=0;
     for i:=qplanes-1 downto 0 do
	  begin
	  qq[i]:=(longint(obr.x)*obr.y- obr.x-obr.y+1 - (qq[i] shr 1)) div 2
			 - koutecku3f;  {qq[i] obsahuje estimativness i-teho smeru}
	  if lm>=qq[i] then
		  begin
		  lm:=qq[i];
		  x:=i;
		  end;
	  end;

   { bitu tabulky }

     if (num > 2*qq[x])and(qplanes>=1) then
	  begin				{vyjmi i ty smer}
	  c:=1 shl x;

	  y:=0;
	  for i:=0 to num-1 do
		  begin
		  if (i and c) <> 0 then continue;
		  a^[y]:=a^[i]+a^[i or c];
		  inc(y);
		  end;

	  for i:= 0 to 15 do
	       begin
	       if (i in numera)and(x>=i) then inc(x);
	       end;
	  numera:=numera+[x];
	  dec(qplanes);

	  goto RepeatReduction
	  end;
     end
     else begin
	  for x:=qplanes-1 downto 0 do
		begin
		num:=1 shl qplanes;
		if x in Numera then
			begin
			c:=1 shl x;

			y:=0;
			for i:=0 to num-1 do
				begin
				if (i and c) <> 0 then continue;
				a^[y]:=a^[i]+a^[i or c];
				inc(y);
				end;
			dec(qplanes);
			end;
		end;
	  num:=1 shl qplanes;
	  end;

fillchar(SmaskF,Sizeof(SmaskF),0);
koutecku3f:=0;
for i:=0 to Num-1 do
	begin
	inc(koutecku3f,abs(a^[i]));
	if a^[i]<0 then SetBinPix(i,addr(SmaskF));
	end;

dispose(a);
SchCount3d2x3a_:=(longint(obr.x)*obr.y- obr.x-obr.y+1 -koutecku3f) div 2;

{WriteMask('dbg_2.txt',Num,addr(SmaskF));{}
end;



{This procedure perform compression of the selected bit plane and known predictor}
Function SchComp3d2x3a(var obr,PlaneC:Picture;n:byte;var numera:tnums;var SmaskF:TsmaskFull):Longint;
var x,y:Word;
    Rmask,OldRmask:byte;
    i:word;
    koutecku3f:longint;
    p0,p1,p2,p3,p4,p5,p6:^Byte;

    plane2a,plane2b,plane3a,plane3b,plane4a,plane4b:pointer;
    lpl:word;
    SmaskEx:TsmaskFull;
    n2plane,n3plane,n4plane:Byte;

label repeatReduction;
begin
if ((n>obr.Planes)or(not(Obr.Valid))) then exit;
if ((PlaneC.Planes<>1)or(not(PlaneC.Valid))) then
	PeelPlane(obr,PlaneC,n);

ExplodeBitFlags(numera,SmaskF,SmaskEx);

lpl:=(Obr.x+7) div 8;
Getmem(plane2a,lpl);
Getmem(plane2b,lpl);
Getmem(plane3a,lpl);
Getmem(plane3b,lpl);
Getmem(plane4a,lpl);
Getmem(plane4b,lpl);

fillchar(plane2a^,lpl,0);
fillchar(plane2b^,lpl,0);
fillchar(plane3a^,lpl,0);
fillchar(plane3b^,lpl,0);
fillchar(plane4a^,lpl,0);
fillchar(plane4b^,lpl,0);

Setn3n4forRGB(obr,n,n2plane,n3plane,n4plane);

Peel1Plane(Obr,Obr.y-1,n2plane,plane2b);
Peel1Plane(Obr,Obr.y-1,n3plane,plane3b);
Peel1Plane(Obr,Obr.y-1,n4plane,plane4b);

for y:=Obr.y-2 downto 0 do		{hlavni radkova smycka}
	begin
	if n<obr.planes then
		begin
		p3:=plane2a;plane2a:=plane2b;plane2b:=p3;
		Peel1Plane(Obr,y,n2plane,plane2b);

		if n+1<obr.planes then
		     begin
		     p5:=plane3a;plane3a:=plane3b;plane3b:=p5;
		     Peel1Plane(Obr,y,n3plane,plane3b);
		     if n+2<obr.planes then
			begin
			p6:=plane4a;plane4a:=plane4b;plane4b:=p6;
			Peel1Plane(Obr,y,n4plane,plane4b);
			end;
		     end;
		end;

	p2:=pointer(PlaneC.data^[y+1]);
	p1:=pointer(PlaneC.data^[y]);
	if y=0 then p0:=p1
	       else p0:=pointer(PlaneC.data^[y-1]);

	p3:=plane2b;
	p4:=plane2a;

	p5:=plane3a;
	p6:=plane4a;

	inc(p0,(Obr.x-1) shr 3);
	inc(p1,(Obr.x-1) shr 3);
	inc(p2,(Obr.x-1) shr 3);
	inc(p3,(Obr.x-1) shr 3);
	inc(p4,(Obr.x-1) shr 3);
	inc(p5,(Obr.x-1) shr 3);
	inc(p6,(Obr.x-1) shr 3);

	Rmask:=128 shr ((Obr.x-1) and 7);

	i:=0;
	if (p0^ and Rmask) <> 0 then inc(i,64);
	if (p1^ and Rmask) <> 0 then inc(i,256);	{obr.x-1 sloupec}
	if (p2^ and Rmask) <> 0 then inc(i,1024);
	if (p3^ and Rmask) <> 0 then inc(i,4);
	if (p4^ and Rmask) <> 0 then inc(i,16);

	OldRmask:=Rmask;
	rmask:=rmask shl 1;
	if rmask=0 then
		   begin
		   rmask:=1;
		   dec(p0);
		   dec(p1);
		   dec(p2);
		   dec(p3);
		   dec(p4);
		   end;

	for x:=Obr.x-2 downto 0 do
		begin
		i:= ((i shl 1)and $AA8);		{blbe}
		if (p0^ and Rmask)<>0 then
			i:=i or 64;
		if (p1^ and Rmask)<>0 then i:=i or 256;
		if (p2^ and Rmask)<>0 then i:=i or 1024;
		if (p3^ and Rmask)<>0 then
			i:=i or 4;
		if (p4^ and Rmask)<>0 then
			 i:=i or 16;
		if (p5^ and OldRmask)<>0 then
			i:=i or 2;
		if (p6^ and OLdRmask)<>0 then
			i:=i or 1;

		OldRmask:=Rmask;
		if OldRmask=1 then
		       begin
		       dec(p5);
		       dec(p6);
		       end;
		rmask:=rmask shl 1;
		if rmask=0 then
			begin
			rmask:=1;
			dec(p0);
			dec(p1);
			dec(p2);
			dec(p3);
			dec(p4);
			end;


		if ((GetBinPix(i and 2047,addr(SmaskEx))<>0))
			then
			begin
			if (i>=2048) then SetPixel(planeC,x+1,y+1,0)  {px=1}
				     else SetPixel(planeC,x+1,y+1,1); {px=0}
			end
{                        else begin
			 if (i>=512) then SetPixel(obr,x+1,y+1,1)	px already 1
				  else SetPixel(obr,x+1,y+1,0); px already 0
			 end;}

		end;
	end;

Freemem(plane2a,lpl);
Freemem(plane2b,lpl);
Freemem(plane3a,lpl);
Freemem(plane3b,lpl);
Freemem(plane4a,lpl);
Freemem(plane4b,lpl);
end;

{------------------------}
{This procedure perform decompression of the selected compressed bit plane and known predictor}
Function DeSchless3d2x3a(var obr,PlaneC:Picture;n:byte;var numera:tnums;var SmaskF:TsmaskFull):Longint;
var x,y:Word;
    mask:byte;
    i:word;
    p0,p1,p2,p3,p4,p5,p6:^Byte;
    plane2a,plane2b,plane3,plane4:pointer;
    lpl:word;

    SmaskEx:TsmaskFull;
    n2plane,n3plane,n4plane:Byte;

label repeatReduction;
begin
if ((n>obr.Planes)or((not(Obr.Valid))or not(planeC.Valid))) then exit;
ExplodeBitFlags(numera,SmaskF,SmaskEx);

lpl:=(Obr.x+7) div 8;
Getmem(plane2a,lpl);
Getmem(plane2b,lpl);
Getmem(plane3,lpl);
Getmem(plane4,lpl);

fillchar(plane2a^,lpl,0);
fillchar(plane2b^,lpl,0);
fillchar(plane3^,lpl,0);
fillchar(plane4^,lpl,0);

Setn3n4forRGB(obr,n,n2plane,n3plane,n4plane);

Peel1Plane(Obr,0,n2plane,plane2a);

for y:=0 to Obr.y-2 do		{hlavni radkova smycka}
	begin
	if n<obr.planes then
		begin
		if numera-[0,1,6..15]<>[2..5] then
		  begin
		  p3:=plane2a;plane2a:=plane2b;plane2b:=p3;
		  Peel1Plane(Obr,y+1,n2plane,plane2a);
		  end;

		if n+1<obr.planes then
		     begin
		     if not(1 in Numera) then
			begin
			Peel1Plane(Obr,y+1,n3plane,plane3);
			end;

		     if n+2<obr.planes then
			begin
			if not(0 in Numera) then
			    begin
			    Peel1Plane(Obr,y+1,n4plane,plane4);
			    end;
			end;
		     end;
		end;


	p2:=pointer(PlaneC.data^[y+1]);
	p1:=pointer(PlaneC.data^[y]);
	if y=0 then p0:=p1
	       else p0:=pointer(PlaneC.data^[y-1]);


	p3:=plane2b;
	p4:=plane2a;

	p5:=plane3;
	p6:=plane4;


	i:=0;
	if (p0^ and 128) <> 0 then inc(i,128);
	if (p1^ and 128) <> 0 then inc(i,512);
	if (p2^ and 128) <> 0 then inc(i,2048);
	if (p3^ and 128) <> 0 then inc(i,8);
	if (p4^ and 128) <> 0 then inc(i,32);

	mask:=64;

	for x:=0 to Obr.x-2 do
		begin
		i:= ((i shr 1)and $554);
		if (p0^ and mask)<>0 then i:=i or 128;
		if (p1^ and mask)<>0 then i:=i or 512;
		if (p2^ and mask)<>0 then i:=i or 2048;
		if (p3^ and mask)<>0 then i:=i or 8;
		if (p4^ and mask)<>0 then i:=i or 32;
		if (p5^ and mask)<>0 then i:=i or 2;
		if (p6^ and mask)<>0 then i:=i or 1;

		if ((GetBinPix(i and 2047,addr(SmaskEx))<>0)) then
			begin
			i:=i xor 2048;
			p2^:=p2^ xor mask;
			end;

		mask:=mask shr 1;
		if mask=0 then
			begin
			mask:=128;
			inc(p0);
			inc(p1);
			inc(p2);
			inc(p3);
			inc(p4);
			inc(p5);
			inc(p6);
			end;

		end;
	end;


Freemem(plane2a,lpl);
Freemem(plane2b,lpl);
Freemem(plane3,lpl);
Freemem(plane4,lpl);
end;


{^^^^^^ Main procedure for storing an image to the disk file ^^^^^^^^}
Function SavePictureFtG(var p:picture;AlineProc:PAbstractLineProc):Boolean;
var Header:FtGrHeader;
    ObjLeader:FtGrObject;
    PalObj:FtgrPalette;
    ImgRec:FtgrImage;

    f:file;
    Ldblk:Word;
    x,y:integer;
    lastX:longint;
    i:Word;
    
    bit:BitStream;
    planeX:picture;
    koutecku:longint;
    Smask1d:TSmask1d;
    CompBuffer:pointer;
    ishuffman:Byte;		{!!!!!}
    Aha:Ahuf;
    Bha:Bhuf;
    Cha:Chuf;
    pb:^Byte;
    rotm:Byte;
    renums:Tnums;
    mFull:TSmaskFull;

    Hufn:Byte;
    HufZero:Longint;
    HufMax:Longint;
    MaxHuTbSize:word;

    StartPos:Longint;

    StringKoren,Astring:Pretezec;
    xStr,yStr:integer;
    pBStr:pbyte;

    {s:string;{!!!!}
    {txt:text;{!!!!!}

label KONEC,NewExit;
begin
 planeX.init;
 CompBuffer:=nil;
 StringKoren:=nil;
 SavePictureFTG:=False;
 if p.data=nil then exit;

 if AlineProc<>nil then
		AlineProc^.InitPassing(p.y*p.planes,'Saving FTG');
 assign2(f,p.filename^);
 filemode:=2;
 rewrite(f,1);
 if IOresult<>0 then exit;

 Header.identific:='F&Tg';	{write image Header to disk}
 Header.Ver:=2;
 Blockwrite(f,Header,sizeof(Header),Ldblk);
 if IOresult<>0 then exit;

 ObjLeader.Typ:=4;	{=image;}
 ObjLeader.Size:=maxlongint;
 StartPos:=filepos(f);
 blockwrite(f,ObjLeader,Sizeof(ObjLeader));

 fillchar(ImgRec,Sizeof(ImgRec),#0);
 ImgRec.Rows:=p.x;
 ImgRec.Cols:=p.y;
 ImgRec.Planes:=p.planes;
 if p.Palette<>nil then ImgRec.Interpretation:=Inside_Palette;
 if p.typ='C' then ImgRec.Interpretation:=Inside_RGB;
 ImgRec.Compression:=FtGrCompression;
 Blockwrite(f,ImgRec,sizeof(ImgRec),Ldblk);

 ldblk:=(p.planes*p.x+7) div 8;

 if ImgRec.Compression<>0 then
    begin
    if (p.x+p.y)<8 then ImgRec.Compression:=0; {too small picture}
    end;

 if ImgRec.Compression<>0 then
    begin
    if (ImgRec.Compression and ReMapPal)<>0 then
	  begin
	  if p.palette<>nil then
	    ReMapPalette(p)
	  else
	    if (ImgRec.Compression and GrayCode)<>0 then Bin2Gray(p);{}
	  end;

    ldblk:=(p.x+7) div 8;
    GetMem(CompBuffer,CBufSize);
    initBitStream(bit,CompBuffer,CBufSize,@f,0);

{    for lastX:=1 to 100000 do writenumber(bit,lastX);{}
{    for x:=1 to 2000 do writenumber(bit,x);	{---test---}

    for i:=p.planes downto 1 do
	begin
	PeelPlane(p,planeX,i);

	if PlaneX.Data=nil then break;

{	fillchar(mFull, sizeof(mFull), 0);
	mFull[0]:=204;
	renums:=[0..7];
	SchComp3d2x3a(p,planeX,i,renums,Mfull);{dodatecne pridano!!!}
{	planeX.view(nil);{}

	renums:=[];
	if (ImgRec.Compression and SchMask < Schless_3d)
		     then renums:=[0..7]
		     else
		     begin
		     if (ImgRec.Compression and SchMask < Schless_3dvar) then renums:=[0,1,6,7];
		     end;

	koutecku:=SchCount3d2x3a(p,planeX,i,renums,mFull)+1;

	y:=0;
	for x:= 0 to ProbeCells do if not(x in renums) then inc(y);
					{je vhodne rovinu komprimovat?}

	if (2.5*Koutecku)+(1 shl y) < (longint(planeX.x-1))*(planeX.y-1){}
		then
		begin
		writebit(bit,True);

		if (ImgRec.Compression and SchMask < Schless_3dvar) then
			begin
			if renums=[0..7] then writebit(bit,False)
					 else writebit(bit,True);
			end
			else writenBits(bit,16,renumS);

		 writenBits(bit,(1 shl y),mFull);

		 SchComp3d2x3a(p,planeX,i,renums,Mfull);


		 Schless1d(planeX,0,0,$FFFF,0,Smask1d); {0 ty radek}
		 writenBits(bit,2,Smask1d);
		 Schless1d(planeX,0,0,0,$FFFF,Smask1d);	{0 ty sloupec}
		 writenBits(bit,2,Smask1d);


{		 planex.view(nil); readln;{!!!!!!!!!!}
{		 savepicture(planex,'i:planex.txt',nil);}
{	str(i,s);savepicture(planex,'c:\temp\'+S+'.BMP',nil);{!!}

{-------Huffmanova komprese--LZW------------}
		 xStr:=-1;yStr:=-1;
		 Astring:=nil;
		 isHuffman:=0;
		 if (ImgRec.Compression and HufMask)<>0 then
			begin
			isHuffman:=1;		{True}
			fillchar(aha,sizeof(aha),0);

{----------Detekce retezcu v obrazku-------}
                        if (ImgRec.Compression and StringDetect)<>0 then
                            begin
                            Nalezni_retezce(planex, StringKoren);
                            if StringKoren<>nil then
				 begin
				 isHuffman:=2;	{True+String}
				 Astring:=StringKoren;
                                 while Astring<>nil do
                                       begin
				       inc(aha[-1]);
                                       SetPixel(planex,Astring^.x,Astring^.y,1);
				       Astring:=Astring^.Next;
				       end;
                                 end;

                            end;
{-----konec detekce retezcu v obrazku-------}

			
			lastX:=-1;
			for y:=0 to planeX.y-1 do
			    begin
			    Rotm:=128;
			    pb:=pointer(planeX.data^[y]);

			    for x:=0 to planeX.x-1 do
				begin
				if pb^ and rotm <> 0 then
					begin
					lastX:=longint(x)-LastX;
					if lastX>MaxHItems then lastX:=0;
					inc(aha[lastX]);
					lastX:=x;
					end;

				Rotm:=Rotm shr 1;
				if Rotm=0 then
					begin
					Rotm:=128;
					inc(pb);
					end;
				end;
			    lastX:=lastX - planeX.x;
			    end;
			 if lastX<0 then
				begin
				lastX:= -LastX;
				if lastX>MaxHItems then lastX:=0;
				inc(aha[lastX]);
				end;

{		assign(txt,'c:\temp\hist_p.txt');
		rewrite(txt);
		for y:=0 to MaxHItems do
		  begin; writeln(txt,y,' ',aha[y]); end;
		close(txt);		{!!!!!}

			HufZero:=aha[0];
			HufMax:=0;
			y:=0;

			if (ImgRec.Compression and HufMask)>=HuffVar then
			  begin
			  for HufN:=0 to 6 do
			    begin
			    aha[0]:=HufZero;
			    for x:=Hu2Sizes[HufN]+1 to MaxHitems do inc(aha[0],aha[x]);
			    huffman(addr(aha[1-isHuffman]),bha,Hu2Sizes[HufN]+isHuffman-1);

				{calculate a difference-stream length}
(*			    lastX := aha[0] * bha[0].size;
			    for x:=Hu2Sizes[HufN]+1 to MaxHitems do
				inc(lastX,sizenum(x-Hu2Sizes[HufN]));

			    for x:=1 to Hu2Sizes[HufN] do
				  begin
				  inc(lastX, aha[x]*(longint(bha[x+isHUffman-1].size)));
				  end;			  {zmena delky dat}

			    MaxHuTbSize:=PackSizes_(nil,bha,Hu2Sizes[HufN]+isHUffman-1,isHUffman);
			    inc(lastX,MaxHuTbSize);		   {!!!delka tabulky}

			    if (LastX>HufMax+500)and(Hu2Sizes[HufN]>32)
					 then break;   {-- funkce uz klesa}
			    if (lastX<HufMax) or (Hufn=0) then
				  begin
				  HufMax:=LastX;
				  y:=HufN;
				  end;  *)

			    lastX:=aha[0]*(Hu2Prefix[HufN]-bha[0].size);
			    for x:=1 to Hu2Sizes[HufN] do
				  begin
				  lastX:=lastX+ aha[x]*(longint(sizenum(x))-bha[x+isHUffman-1].size);
				  end;			  {zmena delky dat}

			    MaxHuTbSize:=PackSizes_(nil,bha,Hu2Sizes[HufN]+isHUffman-1,isHUffman);

			    lastX:=LastX-MaxHuTbSize;		   {!!!delka tabulky}
			    if (LastX<HufMax+18)and(Hu2Sizes[HufN]>32)
					 then break;   {-- funkce uz klesa}
			    if lastX>HufMax then
				  begin
				  HufMax:=LastX;
				  y:=HufN;
				  end;

			    end;
			   end
			   else begin
				y:=1;
				HufMax:=5;
				end;


		{		   inc(aha[-1],100);!!!!}

			  HufN:=y;
			  aha[0]:=HufZero;
			  for x:=Hu2Sizes[HufN]+1 to MaxHitems do inc(aha[0],aha[x]);
			  huffman(addr(aha[1-isHuffman]),bha,Hu2Sizes[HufN]+isHuffman-1);


			  sortSize(bha,cha,Hu2Sizes[HufN]+isHUffman-1);
			  if not(hufcount(bha,cha,Hu2Sizes[HufN]+isHUffman-1)) then
			       isHuffman:=0;
			  sortNum(bha,Hu2Sizes[HufN]+isHUffman-1);

			  if (HUfMax<=4) then isHuffman:=0; {!!! disable Huffman}
			  if isHuffman>0 then
				begin
				if(PackSizes_(nil,bha,Hu2Sizes[HufN]+isHUffman-1,isHUffman)=0) then isHuffman:=0;  {tohle zatim neumim}
				end;
			  end;


		if (ImgRec.Compression and StringDetect)<>0
				then writeNBits(bit,2,isHuffman)
				else writeNBits(bit,1,isHuffman);
		if isHuffman>0 then
			begin
			WriteNBits(bit,3,HufN);

			PackSizes_(addr(Bit),bha,Hu2Sizes[HufN]+isHUffman-1,isHuffman);

			for x:=0 to Hu2Sizes[HufN]+isHUffman-1 do
				begin
				bha[x].code:=prohod(bha[x].code,bha[x].size);
				end;
			end;

	       if (StringKoren<>nil) then
			begin
			if (isHuffman=0)and(StringKoren<>nil) then
			   PutAllStrings(planeX,StringKoren,True);
			if (StringKoren<>nil) then
				begin
				Astring:=StringKoren;
				xStr:=Astring^.x;
				yStr:=Astring^.y;
				end;
			end;
{-------konec Huffmanovy komprese--LZW------------}

		 lastX:=-1;
		 for y:=0 to planeX.y-1 do
		    begin
		    Rotm:=128;
		    pb:=pointer(planeX.data^[y]);

		    for x:=0 to planeX.x-1 do
			begin
			if pb^ and rotm <> 0 then
				begin
				if isHuffman>0
					then begin
					     writeHufNum(bit,bha,longint(x)-LastX,HufN,isHuffman-1);
					     if (isHuffman >1)and((xStr=x)and(yStr=y)) then
						   begin
						   writeNbits(bit,bha[0].size,bha[0].code);{!!!!!}
						   writeNumber(bit,Astring^.length);
						   pBStr:=Astring^.data;
						   for xStr:=0 to Astring^.length-1 do
							begin
							dec(PBStr^);
							writeNbits(bit,3,PBStr^);
							inc(PBStr);
							end;


						   xStr:=-1;yStr:=-1;
						   AString:=AString^.Next;
						   if (AString<>nil) then
							 begin
							 xStr:=Astring^.x;
							 yStr:=Astring^.y;
							 end;

						   end;
					     end
					else writeNumber(bit,longint(x)-LastX);

				lastX:=x;
				end;
			Rotm:=Rotm shr 1;
			if Rotm=0 then
				  begin
				  Rotm:=128;
				  inc(pb);
				  end;
			end;
		    lastX:=lastX - planeX.x;
		    if AlineProc<>nil then AlineProc^.NextLine;
		    end;
		 if lastX<-1 then
			begin
			if isHuffman >0
				then writeHufNum(bit,bha,0-LastX,HufN,isHuffman-1)
				else writeNumber(bit,0-LastX);
			end;
		 end
	    else begin
		 writeBit(bit,False);
		 for y:=0 to planeX.y-1 do
		    begin
		    pb:=pointer(planeX.data^[y]);
		    inc(pb,(p.x-1) shr 3);
		    pb^:=prohod(pb^,8);
		    writenBits(bit,p.x,planeX.data^[y]^);
		    pb^:=prohod(pb^,8);
		    if AlineProc<>nil then AlineProc^.NextLine;
		    end;
		 end;

	if (StringKoren<>nil) then
		   PutAllStrings(planeX,StringKoren,False);

	end;

    WriteToFileBit(bit);
    if (p.palette=nil)and((ImgRec.Compression and GrayCode)<>0) then Gray2Bin(p);

    end;

 if ImgRec.Compression=0 then
    begin
    for y:=0 to p.y-1 do		{no compression}
	begin
	BlockWrite(f,p.data^[y]^,LdBlk);
	AlineProc^.NextLine;
	end;
    end;

 if ObjLeader.Size=maxlongint then
	begin
	ObjLeader.Size:=Filepos(f)-StartPos-Sizeof(ObjLeader);
	seek(f,StartPos);
	blockwrite(f,ObjLeader,Sizeof(ObjLeader));
	seek(f,ObjLeader.Size+StartPos+Sizeof(ObjLeader))
	end;

 if p.palette<>nil then		{ulozeni palety}
	begin
	ObjLeader.Typ:=20;	{=palette;}
	ObjLeader.Size:=p.palette^.colors*3+Sizeof(PalObj);
	blockwrite(f,ObjLeader,Sizeof(ObjLeader));

	PalObj.Items:=p.palette^.colors;
	PalObj.typ:=3;
	PalObj.StartItem:=0;
	PalObj.DestPlanes:=p.Planes;
	Blockwrite(f,PalObj,sizeof(PalObj),Ldblk);

	blockwrite(f,p.palette^.pal,3*p.palette^.colors);
	end;

KONEC:
 close(f);
 if IOResult<>0 then Goto NewExit;
 SavePictureFtG:=True;
NewExit:
 if CompBuffer<>nil then Freemem(CompBuffer,CBufSize);
 planeX.done;
end;


{^^^^^^ Main procedure for loading an image from the disk file ^^^^^^^^}
Function LoadPictureFtG(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    Header:FtGrHeader;
    Obj:FtGrObject;
    Img:FtgrImage;
    Pal:FtgrPalette;

    NewPos:longint;
    ukpalette:Ppalette;
    Ldblk:Word;
    x,y:integer;
    NewX:Longint;
    i,num:byte;
    CompBuffer:Pointer;
    bit:BitStream;
    planeX:picture;
    Smask1dx,Smask1dy:TSmask1d;
    pictdata:pointer;
    renums:Tnums;
    mFull:TSmaskFull;
    pb:^byte;

    bha:Bhuf;
    cha:Chuf;
    isHuff:byte;

    Hufn,HufTblSize:Byte;

    tempL:longint;

    StringLen:Word;
    pStr,pStr2:PByte;
    Sc:word;
    {txt:text;}
label KONEC;

begin
{	assign2(txt,'dbg~.txt');rewrite(txt);}
 LoadPictureFtG:=0;
 p.Erase;

 planeX.init;
 CompBuffer:=nil;
 ukPalette:=nil;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureFtG:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
 if Header.Identific<> 'F&Tg' then goto KONEC;

 NewPos:=filepos(f);
 NewPos:=sizeof(Header);
 NewPos:=filepos(f);
 while not(eof(f)) do
   begin
   Seek(f,NewPos);
   BlockRead(f,Obj,sizeof(Obj),Ldblk);
   NewPos:=NewPos+sizeof(Obj)+Obj.Size;
   case Obj.Typ of
     4:begin
       BlockRead(f,Img,sizeof(Img),Ldblk);

       p.Create(Img.Rows,Img.Cols,Img.planes);
       p.Typ:='G';
       if img.interpretation=Inside_RGB then p.Typ:='C';
       if not(p.Valid) then goto Konec;
       if AlineProc<>nil then
		AlineProc^.InitPassing(p.y*p.planes,'Loading FTG');

       ldblk:=(p.planes*p.x+7) div 8;

       if Img.Compression=0 then	{no compression}
	   begin
	   for y:=0 to p.y-1 do
		      begin
		      Blockread(f,p.data^[y]^,LdBlk);
		      AlineProc^.NextLine;
		      end;
	   end;

       if Img.Compression<>0 then	{Schlesinger compression}
	   begin
	   ldblk:=(p.x+7) div 8;

	   GetMem(CompBuffer,CBufSize);
	   initBitStream(bit,CompBuffer,CBufSize,@f, maxlongint);

{	  for NewX:=1 to 100000 do
	      begin
	      ladix:=readNumber(bit);
	      if ladix<>newX then
		      asm int 3; end;
	      end;				{---test---}

	   for i:=p.planes downto 1 do
	      begin
	      planeX.Create(Img.Rows,Img.Cols,1);
	      if not(planeX.Valid) then goto Konec;

	      num:=0;
	      if read_n(bit,1)>0 then
		      begin
		      if (Img.Compression and SchMask < Schless_3dvar) then
			      begin
			      if read_n(bit,1)=0 then renums:=[0..7]
						 else renums:=[0,1,6,7];
			      end
			      else readNBits(bit,16,renums);

		      y:=0;
		      for x:= 0 to ProbeCells do if not(x in renums) then inc(y);

		      fillchar(mFull,sizeof(mfull),0);
		      ReadnBits(bit,(1 shl y),mFull);

		      readnBits(bit,2,Smask1dx);
		      readnBits(bit,2,Smask1dy);

		      if Img.Compression and StringDetect <> 0
				then isHuff:=read_n(bit,2)
				else isHuff:=read_n(bit,1);
		      if isHuff>0 then
			      begin
			      HufN:=0;
			      HufTblSize:=0;
			      fillchar(bha,sizeof(bha),0);

			      ReadNBits(bit,3,HufN);   {Huffman/log code split}

			      if not(UnPackSizes(Bit,bha,Hu2Sizes[HufN]+isHuff-1,HufTblSize,isHuff)) then
					begin
					asm int 3; end;
					goto Konec;
					end;


(*			     if not(hufcount_(bha,Hu2Sizes[HufN]+isHuff-1)) then
				begin
				asm int 3; end;
				LoadPictureFtG:=ErrData;
				goto Konec; {Load ERROR! Bad Huffman codespace!}
				end; *)


			      sortSize(bha,cha,Hu2Sizes[HufN]+isHuff-1);

			      if not(hufcount(bha,cha,Hu2Sizes[HufN]+isHuff-1)) then
				      begin
				      (*
				      assign(txt,'c:\temp\dbghu.txt');rewrite(txt);
				      for y:=0 to Hu2Sizes[HufN] do
					for x:=0 to Hu2Sizes[HufN] do
					  if(bha[x].Number=y) then
					    writeln(txt,y,': len:',bha[x].Size,' cod:',bha[x].Code);
				      close(txt);
				      *)
				      asm int 3; end;
				      LoadPictureFtG:=ErrData;
				      goto Konec;
				      end;


			      inc(HufN,Hu2Prefix[0]); {delka prefixu v bitech}
			      end;

		      NewX:=-1;
		      y:=0;
		      while y<=planeX.y-1 do
			 begin

{oldx:=newx;{!!!}
			 if isHuff>0 then begin
					  tempL:=ReadHufNum(bit,bha,cha,HufN,isHuff-1);
					  if tempL>0 then inc(NewX,tempL);
					  if tempL=-1 then
						     begin
						     StringLen:=ReadNumber(bit);
						     getmem(pStr,StringLen);
						     pStr2:=pStr;
						     for Sc:=1 to StringLen do
							begin
							pStr2^:=0;
							ReadNbits(bit,3,pStr2^);
							inc(pStr2^);
							inc(pStr2);
							end;
						     Put_PixString(pLaneX,NewX,y,StringLen,pStr);

						     freemem(pStr,StringLen);
						     end;

						    { asm int 3; end;}
					  end
				     else inc(NewX,ReadNumber(bit));


{if i=1 then writeln(txt,'x:',NewX,' y:',y,' ',NewX-oldx);{!!!!!!}


			 if NewX>=planeX.x-1 then
			   begin

			   while NewX>planeX.x-1 do	{konec radky}
				begin
				inc(y);
				dec(NewX,planeX.x);
				if AlineProc<>nil then AlineProc^.NextLine;
				end;

			   if (NewX=planeX.x-1)and(y=planeX.y-1) then
				      begin
				      SetPixel(planeX,NewX,y,1);	{last pixel}
				      break;
				      end;
			   end;
			 if y<=planeX.y-1 then SetPixel(planeX,NewX,y,1);
			 end;



		      if (NewX<>0)and(NewX<>planeX.X-1) then
			      begin

{			      planex.view(nil); readln;{}
{			      savepicture(planex,'i:planex_.txt',nil);{}

{			      close(txt);}

			      asm int 3; end;
			      LoadPictureFtG:=ErrData;
			      goto Konec; {Load ERROR!}
			      end;

		      DeSchless1d(planeX,0,0,$FFFF,0,Smask1dx);
		      DeSchless1d(planeX,0,0,0,$FFFF,Smask1dy);

		      DeSchless3d2x3a(p,planeX,i,renums,mFull);{}
		      end
		 else begin
		      for y:=0 to planeX.y-1 do
			  begin
			  readnBits(bit,planeX.x,planeX.data^[y]^);
			  pb:=pointer(planeX.data^[y]);
			  inc(pb,(p.x-1) shr 3);
			  pb^:=prohod(pb^,8);
			  if AlineProc<>nil then AlineProc^.NextLine;
			  end;
		       end;
	      JoinPlane(planeX,p,i);
	      end;
	 if ((Img.Compression and GrayCode)<>0)and
	    (img.interpretation in[Inside_Gray,Inside_RGB]) then
		begin
		Gray2Bin(p);
		end;
	 Seek(f,NewPos);	{correct File Position}
	 end;
      end;

      20:begin
	 if UkPalette=nil then		{nacteni palety}
	      begin
	      blockread(f,Pal,sizeof(pal));
	      x:=Pal.Items;
	      if x<>0 then
		      begin
		      createpalette(UkPalette,Pal.DestPlanes);
		      if x>UkPalette^.colors then x:=UkPalette^.colors;
		      blockread(f,UkPalette^.pal,3*x);
		      end;
	      end;
	 end;
      end;
   end;

 if p.palette=nil  then p.palette:=UkPalette;
 if p.palette<>nil then p.Typ:='P';
KONEC:
 close(f);
 if CompBuffer<>nil then Freemem(CompBuffer,CBufSize);
 if IOResult<>0 then LoadPictureFTG:=ErrRdDisk;
 planeX.done;

{ close(txt);}
end;



{----------------Procedury pro premapovani palety-------------------}
Function EvaluateInterval(mmm:byte;min,max:integer;var pom:picture;var qoc:array of byte;var results:array of longint):Boolean;
var i,j,k,k_shadow,half:integer;
    jval,kval,kval_shadow:longint;
    q:longint;
    b:Byte;
label Pokracuj;
begin
EvaluateInterval:=False;
half:=(max+min) div 2;

Pokracuj:

{qold:=q;
q:=0;
for i:=0 to pom.X-1 do inc(q,results[i]);
writeln(q);{}

j:=min;
jval:=results[j];
for i:=min+1 to half do		{finding minimal element}
	begin
	if results[i]<jval then
		begin
		jval:=results[i];
		j:=i;
		end
	end;

k:=Half+1;
kval:=results[k];
q:=jval+kval +2*Pixel(pom,qoc[j],qoc[k]);
k_shadow:=k;
kval_shadow:=kval;

for i:=Half+2 to max do		{finding element with minimal criterium}
	begin
	if results[i]<kval_shadow then
		begin
		kval_shadow:=results[i];
		k_shadow:=i;
		end;

	if jval+results[i] +2*Pixel(pom,qoc[j],qoc[i])<q then
		begin
		kval:=results[i];
		k:=i;

		q:=jval+kval +2*Pixel(pom,qoc[j],qoc[k]);
		end
	end;

for i:=min to half do		{finding element with minimal criterium pass 2}
	begin
	if kval_shadow+results[i] +2*Pixel(pom,qoc[k_shadow],qoc[i])<q then
		begin
		jval:=results[i];
		j:=i;

		kval:=kval_shadow;
		k:=k_shadow;
		q:=jval+kval +2*Pixel(pom,qoc[j],qoc[k]);
		end
	end;



if q<0 then	{Is change both elements good?}
	begin
	EvaluateInterval:=True;

	results[k]:=-jVal;
	results[j]:=-kVal;

	b:=qoc[k];
	qoc[k]:=qoc[j];
	qoc[j]:=b;

	for i:=0 to pom.X-1 do
		begin
		if (i=j)or(i=k) then continue;

		if (i and mmm)=(j and mmm)
			then begin
			     inc(Results[i],2*Pixel(pom,qoc[i],qoc[j]));
			     dec(Results[i],2*Pixel(pom,qoc[i],qoc[k]));
			     end
			else begin
			     dec(Results[i],2*Pixel(pom,qoc[i],qoc[j]));
			     inc(Results[i],2*Pixel(pom,qoc[i],qoc[k]));
			     end;

		end;

	if mmm>1 then goto pokracuj;
	end;
end;

Procedure NewEvaluation(mmm:word;var pom:picture;var qoc:array of byte;var results:array of longint);
var i,j:integer;
begin
fillchar(results,sizeof(results),0);
for i:=0 to pom.x-1 do
  for j:=0 to pom.x-1 do
	begin
	if i=j then continue;
	if (i and mmm)=(j and mmm) then inc(Results[i],Pixel(pom,qoc[i],qoc[j]))
				   else dec(Results[i],Pixel(pom,qoc[i],qoc[j]));
	end;

end;


Procedure Bin2Gray(var obr:picture);
var i,j,k:integer;
    qoc:array[0..255] of byte;

    LastPlanes:Byte;
    LastSizeX:Word;
    LastTyp:char;
begin
if (not(obr.valid) or (obr.palette<>nil))or(obr.planes<=3)
			 then exit;

LastPlanes:=Obr.Planes;
LastSizeX:=Obr.X;
LastTyp:=Obr.Typ;
if (obr.planes>8) then
	begin
	k:=LastPlanes div 8;
	obr.planes:=8;
	obr.typ:='G';
	Obr.X:=Obr.X*k;
	end;

fillchar(qoc,sizeof(qoc),0);
qoc[1]:=1;
for i:=0 to 6 do
   begin
   k:=1 shl (i+1);
   for j:=k to 2*k-1 do
	  begin
	  qoc[j]:=qoc[2*k-1  - j] or k;
	  end;
   end;

Operation1(obr,ReTabB,addr(qoc),nil);
Obr.Planes:=LastPlanes;
Obr.X:=LastSizeX;
Obr.Typ:=LastTyp;
end;

Procedure Gray2Bin(var obr:picture);
var i,j,k:integer;
    qoc,qoc2:array[0..255] of byte;
    LastPlanes:Byte;
    LastSizeX:Word;
    LastTyp:char;
begin
if (not(obr.valid) or (obr.palette<>nil))or(obr.planes<=3)
			 then exit;

LastPlanes:=Obr.Planes;
LastSizeX:=Obr.X;
LastTyp:=Obr.Typ;
if (obr.planes>8) then
	begin
	k:=LastPlanes div 8;
	obr.planes:=8;
	obr.typ:='G';
	Obr.X:=Obr.X*k;
	end;

fillchar(qoc,sizeof(qoc),0);
qoc[1]:=1;
for i:=0 to 6 do
   begin
   k:=1 shl (i+1);
   for j:=k to 2*k-1 do
          begin
	  qoc[j]:=qoc[2*k-1  - j] or k;
          end;
   end;

for i:=0 to (1 shl obr.planes)-1 do qoc2[qoc[i]]:=i;	{inverzni funkce qoc}
Operation1(obr,ReTabB,addr(qoc2),nil);
Obr.Planes:=LastPlanes;
Obr.X:=LastSizeX;
Obr.Typ:=LastTyp;
end;



Procedure ReMapPalette(var obr:picture);
type arrW=array[0..3000] of word;
var i,j,k,l:integer;
    ukl,ukl2,ukw,ukw2:^word;
    ukwPix:^word;
    ukwPixA:^arrW;
    q:longint;

    pom:picture;
    qoc,qoc2:array[0..255] of byte;
    results:array[0..255] of longint;
    OldPal,NewPal:Ppalette;
begin
if (not(obr.valid) or (obr.palette=nil))or(obr.planes>8) then exit;

pom.Init;
i:=1 shl obr.planes;
pom.Create(i,i,16);
if not(pom.Valid) then exit;

getmem(ukw,2*obr.x);
getmem(ukl,2*obr.x);

for i:=0 to obr.y-1 do
	begin
	ukw2:=ukl;	{swapping wkw and ukl}
	ukl2:=ukw;
	ukw:=ukw2;
	ukl:=ukl2;

	formr(obr,i,ukw);

	if i=0 then begin
		    for j:=0 to obr.x-2 do
			begin
			ukwPixA:=pointer(pom.data^[ukw2^]);
			inc(ukw2);
			inc(ukwPixA^[ukw2^]);
			{inc(ukwPixA^[0]); {!?!!!!}
			end;
		    end
	       else begin
		    for j:=0 to obr.x-2 do
			begin
			ukwPixA:=pointer(pom.data^[ukw2^]);
			inc(ukw2);

			inc(ukwPixA^[ukw2^]);
			inc(ukwPixA^[ukl2^]);
			if j>0 then
			       begin
			       dec(ukl2);
			       inc(ukwPixA^[ukl2^]);
			       inc(ukl2);
			       end;
			inc(ukl2);
{			inc(ukwPixA^[ukl2^]);{}
			end;
		    end;
	end;

freemem(ukw,2*obr.x);
freemem(ukl,2*obr.x);

for i:=0 to pom.x-1 do		{trojuhelnikova matice - vyrovnej nad a pod diagonalou}
  begin
  for j:=i+1 to pom.x-1 do
	begin
	ukw:=PixelPtr(pom,i,j);
	ukl:=PixelPtr(pom,j,i);

	q:=ukw^+ukl^;
	if q>65534 then
		begin
		asm int 3; end; {overflow error}
		q:=65534;
		end;
	ukw^:=q;
	ukl^:=q;
	end;
  end;
SavePicture(pom,'h:\pom.txt',nil);{!!!!!!!!!!}

{for i:=0 to 255 do qoc[i]:=i;{}
SortPal(obr.palette,qoc);{}


q:=pom.x;
for j:=obr.planes downto 1 do
	begin
	k:=1 shl (j-1);
	NewEvaluation(k,pom,qoc,results);

	l:=0;
	i:=0;
	repeat
	   inc(l,q);
	   if EvaluateInterval(k,i,(i+q)-1,pom,qoc,results)
		   then l:=0;

	   i:=(i+q)mod pom.x
	until (l>=pom.x)or(q=pom.x);


	q:=q div 2;
	end;
(* *)
pom.Done;

for i:=0 to Obr.Palette^.Colors-1 do qoc2[qoc[i]]:=i;	{inverzni funkce qoc}
Operation1(obr,ReTabB,addr(qoc2),nil);

OldPal:=Obr.Palette;			{premapovani palety}
Obr.Palette:=nil;
CreatePalette(Obr.palette,Obr.planes);
for i:=0 to OldPal^.Colors-1 do
	begin
	Obr.Palette^.pal[i]:=OldPal^.pal[qoc[i]];
	end;
NewPal:=Obr.Palette;
Obr.Palette:=OldPal;
ErasePalette(Obr.palette);
Obr.Palette:=NewPal;
end;


{-------------End of FTGR-----------}

Function LoadPictureART(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    k,width,heigth:word;
    Ldblk:Word;
    i:word;
    dummy:longint;
label KONEC;
begin
 LoadPictureART:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureART:=InOutRes;
 if(IOresult<>0) then exit;

 BlockRead(f,dummy,2,Ldblk);
 BlockRead(f,width,sizeof(width),Ldblk);
 BlockRead(f,dummy,2,Ldblk);
 BlockRead(f,heigth,sizeof(heigth),Ldblk);

 ldblk:=(width+7) div 8;
 k:=(-ldblk)and $1;

 if(FileSize(f)<>8+(longint(ldblk)+k)*heigth) then
		begin
		LoadPictureART:=ErrAnother;
		goto KONEC;
		end;
 p.Create(width,heigth,1);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading ART');

 for i:=0 to p.y-1 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	Blockread(f,dummy,k);		{docteni do konce radku}
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
KONEC:
 close(f);
 if IOResult<>0 then LoadPictureART:=ErrRdDisk;
end;  {LoadART}


Function LoadPictureBMP(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    delka:Longint;
    Ldblk:Word;
    i:Word;
    Header:BMPHeader;
    Info:BMPInfo_Coreinfo;
    palitem:RGBQuad;
    w:longint;
    k:Byte;
    compression:Byte;
    x,y:integer;
    ptr:myptr;
    ValidHeaderPTR:longint;
label KONEC,End_of_bitmap,Another,InfoReady,Try40;
begin
 LoadPictureBMP:=0;
 compression:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureBMP:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
			{OS/2 Add on}
 if Header.bfType='BA' then BlockRead(f,Header,sizeof(Header),Ldblk);
{	begin
	seek(f,Header.bfReserved1);			{Next image{}
{	BlockRead(f,Header,sizeof(Header),Ldblk);
	if Header.bfType='BA' then
		BlockRead(f,Header,sizeof(Header),Ldblk);
	end;}

 if((Header.bfType='CI') or (Header.bfType='IC')) then
	begin
	x:=filepos(f);  {start info position}
	y:=0;
	x:=0;
	  repeat
	  i:=filepos(f)-sizeof(Header);
	  BlockRead(f,Info,4,Ldblk);
	  if Info.bisize>40 then goto Another;
	  BlockRead(f,Info.BcWidth,Info.bisize-4,Ldblk);
	  case Info.bisize of
		12:if(y<Info.bcplanes*Info.bcBitCount) then begin y:=Info.bcplanes*Info.bcBitCount;x:=i;end;
		40:if(y<Info.biplanes*Info.biBitCount) then begin y:=Info.biplanes*Info.biBitCount;x:=i;end;
		end;
	  seek(f,i+sizeof(Header)+Info.bisize+6{???});
	  BlockRead(f,Header,sizeof(Header),Ldblk);
	  if Header.bfType='BA' then BlockRead(f,Header,sizeof(Header),Ldblk);
	  until Header.bfType<>'CI';
	seek(f,x);	{goto before valid info}
	BlockRead(f,Header,sizeof(Header),Ldblk);
	end;

 if ((Header.bfType<>'BM')and(Header.bfType<>'CI'))or(Ldblk<>Sizeof(Header)) then
			begin
Another:		LoadPictureBMP:=ErrAnother;
			goto konec;
			end;

 BlockRead(f,Info,4,Ldblk);
 if Info.bisize>124 then goto Another;

 case Info.bisize of
	12:begin    {OS/2 V1 BITMAPCOREHEADER  OS/2 and also all Windows versions since Windows 3.0}
	   BlockRead(f,Info.BcWidth,Info.bisize-4,Ldblk);
	   if Info.bcplanes<>1 then goto konec;
	   p.planes:=Info.bcplanes*Info.bcBitCount;
	   p.x:=Info.bcWidth;
	   p.y:=Info.bcHeight;
	   k:=3;	{RGB Triple}
	   end;
	40:begin   {Windows V3 BITMAPINFOHEADER   all Windows versions since Windows 3.0}
	   BlockRead(f,Info.BcWidth,Info.bisize-4,Ldblk);
Try40:	   if Info.biplanes<>1 then goto konec;
	   p.planes:=Info.biplanes*Info.biBitCount;
	   p.x:=Info.biWidth;
	   p.y:=Info.biHeight;
	   Compression:=info.biCompression;

	   if Compression>3 then goto konec;
	    {BI_RGB	An uncompressed format.
	     BI_RLE8	A run-length encoded (RLE) format for bitmaps with 8 bpp.
	     BI_RLE4	An RLE format for bitmaps with 4 bpp.
	     BI_BITFIELDS	Specifies that the bitmap is not compressed.
	     !BI_JPEG	Specifies that the image is compressed using the JPEG file interchange format.
	     !BI_PNG	Specifies that the image is compressed using the PNG file interchange format.}
	   k:=4;	{RGB Quad}
	   end;
       108:begin	{Windows V4 	BITMAPV4HEADER 	all Windows versions since Windows 95/NT4}
	   BlockRead(f,Info.BcWidth,40-4,Ldblk);
	   goto Try40
	   end;
       124:begin	{Windows V5 	BITMAPV5HEADER 	Windows 98/2000 and newer}
	   BlockRead(f,Info.BcWidth,40-4,Ldblk);
	   goto Try40
	   end
	else goto Another;
     end;


 if not(p.planes in [1,4,8,24,32]) then goto Another;	{nepodporovany format}
 if p.planes=32 then
	  begin
	  p.Create(p.x,p.y,24);
	  Compression:=255;
	  end
     else p.Create(p.x,p.y,p.planes);
 if p.data=nil then
    begin
    LoadPictureBMP:=ErrMem;
    goto Konec;
    end;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading BMP');

 if (p.planes=8)or(p.planes=4) then		{nahrani palety}
	begin
	CreatePalette(p.palette,p.planes);
	for i:=0 to (1 shl p.planes)-1 do
		begin
		Blockread(f,palitem,k);
		p.palette^.pal[i].Red:=  PalItem.rgbRed;
		p.palette^.pal[i].Green:=PalItem.rgbGreen;
		p.palette^.pal[i].Blue:= PalItem.rgbBlue;
		end;
	if GrayPalette(p) then ErasePalette(p.palette)
			  else p.typ:='P';
	end;

 Seek(f,Header.bfOffbits);
 ldblk:=(longint(p.planes)*p.x+7) div 8;
 k:=(-ldblk)and $3;

 case Compression of
       0:for i:=p.y-1 downto 0 do
	    begin
	    Blockread(f,p.data^[i]^,LdBlk);
	    Blockread(f,w,k);		{docteni do konce radku}
	    if AlineProc<>nil then AlineProc^.NextLine;
	    end;
       1:begin
	 y:=p.Y-1;
	 x:=0;
	 i:=0;
	 while y>=0 do
	   begin
	   ptr.ptr:=p.data^[y];
	   while not(eof(f)) do
		begin
		Blockread(f,i,2);
		if Lo(i)=0 then		{escape code}
			begin
			i:=Hi(i);
			if i=0 then begin;x:=0;break;end;
			if i=1 then goto End_of_bitmap;
			if i=2 then
				begin
				Blockread(f,i,2);
				inc(x,Lo(i));
				dec(y,Hi(i)-1);
				break;
				end;

			while (i>0)and(x<LdBlk-1) do
			       begin
			       Blockread(f,w,2);
			       ptr.ptrB^:=w;
			       inc(ptr.ptrB);
			       inc(x);
			       dec(i);
			       if (x=LdBlk-1)or(i=0) then
					 begin;i:=0;break;end;
			       ptr.ptrB^:=w shr 8;
			       inc(ptr.ptrB);
			       inc(x);
			       dec(i);
			       end;
			continue;
			end;

		if x>=LdBlk then continue;
		if (Lo(i)>0) then
			begin
			k:=min(LdBlk-x,Lo(i));
			fillchar(ptr.ptrB^,k,Hi(i));
			inc(ptr.ptrB,k);
			inc(x,k);
			dec(i,k);
			end;
		end;
	   dec(y);
	   if AlineProc<>nil then AlineProc^.NextLine;
	   if eof(f) then goto End_of_bitmap;	{unexpected end}
	   end;
	 end;

       2:begin		{BI_RLE4}
	 y:=p.Y-1;
	 x:=0;
	 while y>=0 do
	   begin
	   while not(eof(f)) do
		begin
		Blockread(f,i,2);
		if Lo(i)=0 then		{escape code}
			begin
			i:=Hi(i);
			if i=0 then begin;x:=0;break;end; {end of line}
			if i=1 then goto End_of_bitmap;
			if i=2 then
				begin
				Blockread(f,i,2);
				inc(x,Lo(i));
				dec(y,Hi(i)-1);
				break;
				end;

			k:=0;
			ldblk:=0;
			while (i>0)and(x<p.x) do
			       begin
			       case k of 0:begin
					   Blockread(f,ldblk,2);
					   Setpixel(p,x,y,(ldblk shr 4)and $F);
					   end;
					 1:Setpixel(p,x,y,ldblk and $F);
					 2:Setpixel(p,x,y,ldblk shr 12);
					 3:Setpixel(p,x,y,(ldblk shr 8) and $F);
				      end;
			       inc(x);
			       dec(i);
			       k:=(k+1) and 3;
			       end;
			continue;
			end;

		if (Lo(i)>0) then
			begin
			ldblk:=min(p.x-x,Lo(i));
			k:=Hi(i);
			for i:=1 to ldblk do
				begin
				if odd(i) then Setpixel(p,x,y,k shr 4)
					  else Setpixel(p,x,y,k and $F);
				inc(x);
				end;
			end;
		end;
	   dec(y);
	   if AlineProc<>nil then AlineProc^.NextLine;
	   if eof(f) then goto End_of_bitmap;	{unexpected end}
	   end;
	 end;

    255:for y:=p.y-1 downto 0 do	{fix for 32 bit planes}
	  for x:=0 to p.x-1 do
	     begin
	     Blockread(f,palitem,4);
	     k:=palitem.rgbRed;
	     palitem.rgbRed:=palitem.rgbBlue;
	     palitem.rgbBlue:=k;
	     Setpixel(p,x,y,longint(palitem));
	     end

    end;
End_of_bitmap:

 if p.planes=24 then
   begin
   if(Info.bisize=12) or (Info.bisize=40) then
	for i:=p.y-1 downto 0 do RGB_BGR(p.x,p.data^[i]);
   p.typ:='C';
   end;


KONEC:
 close(f);
 if IOResult<>0 then LoadPictureBMP:=ErrRdDisk;
end;  {LoadBMP}


Function LoadPictureCUT(var p:picture;AlineProc:PAbstractLineProc):integer;
const TranslateType:array[1..3] of byte=(4,1,8);
var f:file;
    ldblk:Longint;
    delka:integer;
    i,j:Word;
    ptrB:^Byte;
    Header:CUTHeader;
    PalHeader:CUTPalHeader;
    Pal:RGBWord;
    EncodedByte:Word;
    RunCount,RunCountMasked,RunValue:Byte;
label KONEC,Konec2;
begin
 LoadPictureCUT:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureCUT:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),delka);
 if (Header.Reserved<>0)or((Header.Height=0)or(Header.Width=0)) then
	 goto konec;
{---This code checks first line of image---}
 Blockread(f,EncodedByte,2);
 Blockread(f,RunCount,1);
 RunCountMasked:=RunCount and $7F;
 ldblk:=0;
 while RunCountMasked>0 do	{end of line?}
		begin
		i:=1;
		if Runcount<$80 then i:=RunCountMasked;
		seek(f,filepos(f)+i);
		if eof(f) then goto konec;	{wrong data}

		dec(EncodedByte,i+1);
		inc(ldblk,RunCountMasked);

		Blockread(f,RunCount,1);
		if eof(f) then goto konec;	{wrong data: unexpected eof in line}
		RunCountMasked:=RunCount and $7F;
		end;
 if EncodedByte<>1 then goto Konec;		{wrong data: size incorrect}
 i:=0;				{guess a number of bit planes}
 if ldblk=Header.Width then   i:=8;
 if 2*ldblk=Header.Width then i:=4;
 if 8*ldblk=Header.Width then i:=1;
 if i=0 then goto konec;			{wrong data: size incorrect}
{-----End of check-----}
 p.Create(Header.Width,Header.Height,i);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading CUT');

 seek(f,sizeof(header));	{Ldblk was set in the check phase}
 for i:=0 to p.y-1 do
	begin
	Blockread(f,EncodedByte,2);

	ptrB:=pointer(p.data^[i]);
	j:=ldblk;

	Blockread(f,RunCount,1);
	RunCountMasked:=RunCount and $7F;
	while RunCountMasked>0 do	{end of line?}
		begin
		if RunCountMasked>j then
				     begin		{Wrong Data}
				     asm int 3; end;
				     RunCountMasked:=j;
				     if j=0 then break;
				     end;

		if Runcount>$80 then
				begin
				Blockread(f,RunValue,1);
				fillchar(ptrB^,RunCountMasked,RunValue)
				end
				else blockread(f,ptrB^,RunCountMasked);

		inc(ptrB,RunCountMasked);
		dec(j,RunCountMasked);

		if eof(f) then goto konec;	{wrong data: unexpected eof in line}
		Blockread(f,RunCount,1);
		RunCountMasked:=RunCount and $7F;
		end;


	if AlineProc<>nil then AlineProc^.NextLine;
	end;

{Try to load a palette}
 close(f);
 if (p.valid) then {jeste zbyva nahrani palety}
	begin
	assign2(f,copy(p.filename^,1,length(p.filename^)-3)+'PAL');
	reset(f,1);
	if IOResult<>0 then goto Konec2;
	blockRead(f,PalHeader,sizeof(PalHeader)); {uvodni informace}
	if IOResult<>0 then goto Konec;
	if PalHeader.FileId<>'AH' then goto konec;

	CreatePalette(p.palette,p.planes);
	for i:=0 to min(PalHeader.MaxIndex,1 shl p.planes -1) do
		begin      {this may be wrong- I don't know why is palette such strange}
		j:=filepos(f);
		if(j mod 512)>512-sizeof(pal) then
			begin
			j:=((j div 512)+1)*512;
			seek(f,j);
			end;
		blockread(f,pal,sizeof(pal));
		p.palette^.pal[i].Red  :=pal.Red;
		p.palette^.pal[i].Green:=pal.Green;
		p.palette^.pal[i].Blue :=pal.Blue;
		end;

	if (GrayPalette(p))or(IOresult<>0) then ErasePalette(p.palette)
					   else p.Typ:='P';
	end;


KONEC:
 if filerec(f).mode<>fmClosed then close(f);
Konec2:
 if IOResult<>0 then LoadPictureCUT:=ErrRdDisk;
end;  {LoadCUT}



Procedure RdFromGIFBit(b:PBitStream); far; {Load GIF file}
var len:Byte;
    ReadedB:word;
begin
 ReadedB:=0;
 if b^.Flag=1 then b^.realBufStart^:=b^.BufEnd^;

 if b^.FileLeft>0 then
	begin
	BlockRead(b^.f^,len,1,ReadedB);
	if len=0 then len:=255;
	if ReadedB<>1 then len:=0;

	b^.ptr:=b^.realBufStart;
	if b^.Flag=1 then inc(b^.ptr);
	BlockRead(b^.f^,b^.ptr^,len,ReadedB);
	dec(b^.FileLeft,ReadedB);
	end;

 if(ReadedB=0) then b^.FileLeft:=0;		{EOF}
 b^.ptr:=b^.realBufStart;
 b^.BufEnd:=b^.realBufStart;
 if b^.flag=1 then inc(ReadedB);
 if odd(ReadedB) then begin;b^.Flag:=1;dec(ReadedB);end
		 else b^.Flag:=0;
 inc(b^.BufEnd,ReadedB);

 if IOResult<>0 then b^.FileLeft:=-1; {error}
end;



{----------------------- Load GIF ----------------------}
type TypeGIFHeader=record
	SignatureMain:packed array[1..3] of Char;
	SignatureRelease:packed array[1..3] of Char;
	Width,Height:Word;
	Flag,BackGround,Nul:Byte;
	end;
     TypeGIFImageDescriptor=record
	Left,Top,Width,Height:Word;
	Flag:Byte;
	end;

Function LoadPictureGIF(var obr:picture;AlineProc:PAbstractLineProc):integer;
Type TOutCode=array[0..4095] of Byte;
     TPrefSuf=array[0..4095] of Word;

var OutCode:^TOutCode;
    Prefix,Suffix:^TprefSuf;
    Nacteno,F:Word;
    Soubor:file;

    I,InCode,OldCode,CurCode,Code,ClearCode,OutCount,FirstFree,FreeCode,EOFCode,MaxCode:word;
    FinChar,BitMask,CodeSize,InitCodeSize:Byte;

    X,Y,Pass:LongInt;
    Interlace:Boolean;
    GIFHeader:TypeGIFHeader;
    GIFImageDescriptor:TypeGIFImageDescriptor;

    bit:Bitstream;
    CompBuffer:pointer;
    palette:PPalette;

const GIFBufSize=512;

 CodeMask:array[1..8] of Byte=(1,3,7,15,31,63,127,255);


procedure AddToPixel(Bajt:Byte);
begin
   SetPixel(Obr,x,y,Bajt);
   Inc(X);
   if X<obr.x then Exit;
   x:=0;
   if AlineProc<>nil then AlineProc^.NextLine;

   if not Interlace then
	begin
	inc(y);
	Exit;
	end;

   case Pass of
       0: begin
	   Y:=Y+8;
	   if Y>=obr.y then
	    begin
	     Inc(Pass);
	     Y:=4;
            end;
	  end;
       1: begin
	   Y:=Y+8;
	   if Y>=obr.y then
	    begin
	     Inc(Pass);
	     Y:=2;
	    end;
	  end;
       2: begin
	   Y:=Y+4;
	   if Y>=obr.y then
	    begin
	     Inc(Pass);
             Y:=1;
            end;
          end;
       3: begin
	   Y:=Y+2;
	  end;
   end;
end; {..AddToPixel..}


label konec,konecErr;
begin
  LoadPictureGIF:=0;
  obr.Erase;
  OutCode:=nil;
  Prefix:=nil;
  Suffix:=nil;
  CompBuffer:=nil;

  assign2(Soubor,Obr.Filename^);
  Reset(Soubor,1);
  if IOResult<>0 then exit;
  BlockRead(Soubor,GIFHeader,SizeOf(GIFHeader),Nacteno);
  if (IOResult<>0)or(Nacteno<SizeOf(GIFHeader)) then
				 goto konec;	{file Error}
  if GIFHeader.SignatureMain<>'GIF' then goto konec;

  if (GIFHeader.Width>0)and(GIFHeader.Height>0) then
      begin
      if AlineProc<>nil then
		AlineProc^.InitPassing(Obr.y,'Loading GIF');
      end;

  seek(soubor,Sizeof(GIFHeader));

  if (GIFHeader.Flag and 128)>0 then		{....LoadGIFPalete....}
	begin
	CreatePalette(Obr.Palette,NearAvailPln(GIFHeader.Flag and 7 + 1));
	if Obr.Palette=nil then goto konec;
	x:=3* (word(2) shl (GIFHeader.Flag and 7));
	BlockRead(Soubor,Obr.palette^.pal,x,Nacteno);
	if (IOResult<>0)or(Nacteno<x) then goto KonecErr;
	end;
  {?-Global Color Map}


  new(OutCode);
  BlockRead(Soubor,OutCode^,1,Nacteno);
  if (IOResult<>0)or(Nacteno<1) then	{Next Byte}
			goto konecErr;

 {?-Extended Bloks}
 while OutCode^[0]=$21 do
	begin
	BlockRead(Soubor,Outcode^,2,Nacteno);
	if IOResult<>0 then goto konecErr;
{	WriteLn('Extension block type: ',Outcode^[0]);}
	CodeSize:=Outcode^[1];
	while CodeSize>0 do
	  begin
	   BlockRead(Soubor,Outcode^,CodeSize+1,Nacteno);
	   if IOResult<>0 then goto konecErr;
	   CodeSize:=Outcode^[CodeSize];
	  end;
	BlockRead(Soubor,Outcode^,1,Nacteno);
	if IOResult<>0 then goto konecErr;
	end;


 if Outcode^[0]=$2c then
     begin
     BlockRead(Soubor,GIFImageDescriptor,sizeof(GIFImageDescriptor),Nacteno);
     if (IOResult<>0)or(Nacteno<sizeof(GIFImageDescriptor)) then goto konecErr;
     Interlace:=(GIFImageDescriptor.Flag and 64 > 0);
     {?-Image Descriptor}

	 {Local Color Map}
     if (GIFImageDescriptor.Flag and 128)>0 then
	    begin
	    CreatePalette(Obr.Palette,NearAvailPln(GIFImageDescriptor.Flag and 7 + 1));
	    if Obr.Palette=nil then goto konec;
	    x:=3* (word(2) shl (GIFImageDescriptor.Flag and 7));
	    BlockRead(Soubor,Obr.palette^.pal,x,Nacteno);
	    if (IOResult<>0)or(Nacteno<x) then goto KonecErr;
	    end;

     if not(Obr.Valid) then	{Image still remain undefined: Terrible situation!}
	  begin
	  Palette:=Obr.Palette;
	  Obr.Palette:=nil;
	  Obr.Create(GIFImageDescriptor.Width,GIFImageDescriptor.Height,NearAvailPln(GIFHeader.Flag and 7 + 1));
	  If not(Obr.Valid) then
		begin
		LoadPictureGIF:=ErrMem;
		goto konec;
		end;
	  Obr.Palette:=Palette;
	  Palette:=nil;
	  If not(Obr.Valid) then goto konec;
	  if AlineProc<>nil then
		AlineProc^.InitPassing(Obr.y,'Loading GIF');
	  end;

     X:=0; Y:=0; Pass:=0;

     BlockRead(Soubor,CodeSize,1,Nacteno);

     ClearCode:=1 shl CodeSize;
     if CodeSize=0 then goto konec;	{GIF error}

     EOFCode:=ClearCode+1;
     FirstFree:=ClearCode+2;
     FreeCode:=FirstFree;

     inc(CodeSize);
     InitCodeSize:=CodeSize;

     MaxCode:=1 shl Codesize;

     if((GIFImageDescriptor.Flag and 7)<>0) then
       BitMask:=CodeMask[GIFImageDescriptor.Flag and 7+1]
     else
       BitMask:=CodeMask[GIFHeader.Flag and 7+1];

     OutCount:=0;

     GetMem(CompBuffer,GIFBufSize);

     new(Prefix);
     new(Suffix);

     initBitStream(bit,CompBuffer,GIFBufSize,@Soubor,MaxLongint);
     bit.FileProc:=RdFromGIFBit; {}

     repeat
      if bit.FileLeft<0 then
	    begin		{load error}
	    goto konecErr;
	    end;
      Code:=Read_N(bit,CodeSize);{}

      if Code<>EOFCode then
	   begin
	    if Code=ClearCode then
	     begin
	      CodeSize:=InitCodeSize;
	      MaxCode:=1 shl CodeSize;
	      FreeCode:=FirstFree;

	      Code:=Read_N(bit,CodeSize);{}

	      CurCode:=Code;
	      OldCode:=Code;
	      FinChar:=Code and BitMask;
	      AddToPixel(FinChar);
	     end
	else
	begin
	CurCode:=Code;
	InCode:=Code;
	if Code>=FreeCode then
	     begin
	      CurCode:=OldCode;
	      OutCode^[OutCount]:=FinChar;
	      inc(OutCount);
	      if Code>FreeCode then
		  begin
		  LoadPictureGIF:=ErrData;
		  break;		{Compression Error}
		  end;
	      end;
	while CurCode>=ClearCode do
	    begin
	     OutCode^[OutCount]:=Suffix^[CurCode];
	     inc(OutCount);
	     CurCode:=Prefix^[CurCode];
	    end;
	FinChar:=CurCode and BitMask;
	OutCode^[OutCount]:=FinChar;
	inc(OutCount);
	for I:=OutCount-1 downto 0 do
		    AddToPixel(Outcode^[I]);
	OutCount:=0;
	Prefix^[FreeCode]:=OldCode;
	Suffix^[FreeCode]:=FinChar;
	OldCode:=InCode;
	inc(FreeCode);
	if FreeCode>=MaxCode then
	     begin
	      if CodeSize<12 then
		 begin
		  inc(CodeSize);
		  MaxCode:=MaxCode*2;
		 end
		 else FreeCode:=FirstFree;
	     end;
       end;
      end;
     until Code=EOFCode;

{   BlockRead(Soubor,Outcode^,1,Nacteno);
   if IOResult<>0 then goto konecerr;}
   end;
goto konec;
konecErr:
 LoadPictureGIF:= ErrRdDisk;
konec:
 if obr.palette<>nil then obr.Typ:='P';
 if CompBuffer<>nil then Freemem(CompBuffer,GIFBufSize);
 if OutCode<>nil then dispose(OutCode);
 if Prefix<>nil then dispose(Prefix);
 if Suffix<>nil then dispose(Suffix);
 if IOResult<>0 then LoadPictureGIF:= ErrRdDisk;
 Close(Soubor);
 if IOResult<>0 then LoadPictureGIF:= ErrRdDisk;
end; {LoadGIF}
{------------------End of - Load GIF --------------------}


{----------------------- Load HRZ ----------------------}
Function LoadPictureHRZ(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    Ldblk:Word;
    i,j:word;
    FixScale:^byte;
label KONEC;
begin
 LoadPictureHRZ:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureHRZ:=InOutRes;
 if(IOresult<>0) then exit;

 if(FileSize(f)<>184320) then
		begin
		LoadPictureHRZ:=ErrAnother;
		goto KONEC;
		end;
 p.Create(256,240,24);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading HRZ');

 for i:=0 to p.y-1 do
	begin
	FixScale:=addr(p.data^[i]^);
	Blockread(f,FixScale^,3*p.x);
	for j:=0 to 3*p.x-1 do
	  begin
	  if(FixScale^>=64) then
		begin
		LoadPictureHRZ:=ErrAnother;
		goto KONEC;
		end;
	  FixScale^:=FixScale^ shl 2;
	  inc(FixScale);
	  end;
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
 p.Typ:='C';
KONEC:
 close(f);
 if IOResult<>0 then LoadPictureHRZ:=ErrRdDisk;
end;  {LoadHRZ}

{------------------End of - Load HRZ --------------------}

Function LoadPictureICO(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    Ldblk:Word;
    i:Word;
    Header:IconHeader;
    Entry:IconDirectoryEntry;
    Info:BMPInfo_Coreinfo;
    RGB:RGBQuad;
label KONEC;
begin
 LoadPictureICO:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureICO:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
 if ((Header.idReserved<>0)or(Header.idType<>1))or(Header.idCount<1) then
	begin
	LoadPictureICO:=ErrAnother;
	goto Konec;
	end;

 BlockRead(f,Entry,sizeof(Entry),Ldblk);
 seek(f,Entry.dwImageOffset);
 BlockRead(f,Info,sizeof(Info),Ldblk);
 if InOutRes<>0 then
	goto Konec;
 if (Info.biWidth<>Entry.bWidth) then {or(Info.biHeight<>Entry.bHeight)}
	begin
	LoadPictureICO:=ErrAnother;
	goto Konec;
	end;

 if(Entry.bColorCount=0) then Entry.bColorCount:=255;
 i:=round(ln(Entry.bColorCount)/ln(2));
 if(i=2) then i:=4;
 p.Create(Entry.bWidth,Entry.bHeight,i);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading ICO');

 CreatePalette(p.palette,p.Planes);
 if Entry.bColorCount<255 then dec(Entry.bColorCount);
 if (Entry.bColorCount>2) and (Entry.bColorCount<15) then Entry.bColorCount:=15;
 for i:=0 to Entry.bColorCount do
	begin
	BlockRead(f,RGB,SizeOf(RGB));
	p.palette^.pal[i].Red:=RGB.RGBRed;
	p.palette^.pal[i].Green:=RGB.RGBGreen;
	p.palette^.pal[i].Blue:=RGB.RGBBlue;
	end;

 ldblk:=(longint(p.planes)*p.x+7) div 8;        {XOR part}
 for i:=p.y-1 downto 0 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
						{AND part is omitted!}
KONEC:
 close(f);
 if IOResult<>0 then LoadPictureICO:=ErrRdDisk;
end;  {LoadICO}


{----------------------- Load MAC ----------------------}
Function LoadPictureMAC(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    Ldblk:word;
    i,j:word;
    rep,b:byte;
    FixScale:^byte;
label KONEC;
begin
 LoadPictureMAC:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureMAC:=InOutRes;
 if(IOresult<>0) then exit;

 Blockread(f,ldblk,2);

 if((ldblk and $FF)<>0) then
	begin
	LoadPictureMAC:=ErrAnother;
	goto Konec;
	end;

 if(ldblk=0) then	{???? don't know why}
   seek(f,$200)
 else
   seek(f,$280);

 p.Create(576,720,1);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading MAC');

 ldblk:=(p.planes*p.x+7) div 8;

 j:=0; i:=0;
 FixScale:=addr(p.data^[0]^);
 while i<p.y do
   begin
   Blockread(f,rep,1);
   if eof(f) then break;

   if (rep>=128) or (rep<=0) then
     begin
     Blockread(f,b,1); b:=not(b);

     rep := not(rep) + 2;
     while(rep>0) do
       begin

       FixScale^ := b;
       inc(FixScale);
       inc(j);
       dec(rep);
       if(j>=ldblk) then
	 begin
	 j:=0;
	 inc(i);
	 if(i<p.y) then
	   begin
	   FixScale:=addr(p.data^[i]^);
	   if AlineProc<>nil then AlineProc^.NextLine;
	   end
	 end
       end
      end
   else
     begin
     inc(rep);
     while(rep>0) do
       begin
       Blockread(f,b,1); b:=not(b);
       FixScale^ := b;
       inc(FixScale);
       inc(j);
       dec(rep);
       if(j>=ldblk) then
	 begin
	 j:=0;
	 inc(i);
	 if(i<p.y) then
	   begin
	   FixScale:=addr(p.data^[i]^);
	   if AlineProc<>nil then AlineProc^.NextLine;
           end
	 end
       end
     end
   end;

KONEC:
 close(f);
 if IOResult<>0 then LoadPictureMAC:=ErrRdDisk;
end;  {LoadMAC}

{------------------End of - Load MAC --------------------}



Function LoadPictureMAT(var p:picture;AlineProc:PAbstractLineProc):integer;
const mxCELL_CLASS = 1;		{ cell array }
      mxSTRUCT_CLASS = 2;	{ structure }
      mxOBJECT_CLASS = 3;	{ object }
      mxCHAR_CLASS = 4;		{ character array }
      mxSPARSE_CLASS = 5;	{ sparse array }
      mxDOUBLE_CLASS = 6;	{ double precision array }
      mxSINGLE_CLASS = 7;	{ single precision floating point }
      mxINT8_CLASS = 8;		{ 8 bit signed integer }
      mxUINT8_CLASS = 9;	{ 8 bit unsigned integer }
      mxINT16_CLASS = 10;	{ 16 bit signed integer }
      mxUINT16_CLASS = 11;	{ 16 bit unsigned integer }
      mxINT32_CLASS = 12;	{ 32 bit signed integer }
      mxUINT32_CLASS = 13;	{ 32 bit unsigned integer }
      mxINT64_CLASS = 14;	{ 64 bit signed integer }
      mxUINT64_CLASS = 15;	{ 64 bit unsigned integer }
      mxFUNCTION_CLASS = 16;    { Function handle }

      miINT8 = 1;		{ 8 bit signed }
      miUINT8 = 2;		{ 8 bit unsigned }
      miINT16 = 3;		{ 16 bit signed }
      miUINT16 = 4;		{ 16 bit unsigned }
      miINT32 = 5;		{ 32 bit signed }
      miUINT32 = 6;		{ 32 bit unsigned }
      miSINGLE = 7;		{ IEEE 754 single precision float }
      miRESERVE1 = 8;
      miDOUBLE = 9;		{ IEEE 754 double precision float }
      miRESERVE2 = 10;
      miRESERVE3 = 11;
      miINT64 = 12;		{ 64 bit signed }
      miUINT64 = 13;		{ 64 bit unsigned }
      miMATRIX = 14;		{ MATLAB array }
      miCOMPRESSED = 15;	{ Compressed Data }
      miUTF8 = 16;		{ Unicode UTF-8 Encoded Character Data }
      miUTF16 = 17;		{ Unicode UTF-16 Encoded Character Data }
      miUTF32 = 18;		{ Unicode UTF-32 Encoded Character Data }

      FLAG_COMPLEX = $800;
      FLAG_GLOBAL =  $400;
      FLAG_LOGICAL = $200;

var f:file;
    delka:Longint;
    DataType:Longint;
    Ldblk:Word;
    i,x:Word;
    Header:MATHeader;
    identif: array[0..5] of char absolute Header;
    z:longint;
    Unknown5:longint;
    pbuf:Picture;
    data:pointer;
    datab:ukLinePict absolute data;
label KONEC,Err_Konec;
begin
 LoadPictureMAT:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureMAT:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header)-4,Ldblk);
 if ((Identif<> 'MATLAB') or (Header.Idx<> #1'IM')) or
    (Header.unknown0<>$0E) then
		begin
		LoadPictureMAT:=ErrAnother;
		goto KONEC;
		end;

  case Header.DimFlag of
     8:begin
       z:=1;
       end;
     12:begin
       BlockRead(f,z,sizeof(z),Ldblk); {3D matrix RGB}
       BlockRead(f,Unknown5,sizeof(Unknown5),Ldblk);
       if(z<>3) then goto Err_Konec;
       end;
     else goto Err_Konec;
   end;

   BlockRead(f,Header.Flag1,sizeof(Header.Flag1),Ldblk);
   BlockRead(f,Header.NameFlag,sizeof(Header.NameFlag),Ldblk);

   i := Header.StructureFlag and $FF;
   if( ((i<>mxDOUBLE_CLASS) and (i<>mxUINT8_CLASS)) and
       ((i<>mxINT16_CLASS) and (i<>mxUINT32_CLASS)) ) then
	begin
Err_Konec:LoadPictureMAT:=ErrData;
	goto KONEC;
	end;

 if((Header.NameFlag>=1)and(Header.NameFlag<=4) ) then
	begin
	BlockRead(f,delka,sizeof(delka),Ldblk); {Object name string}
	end
 else if(Header.NameFlag=0) then begin
      BlockRead(f,delka,sizeof(delka),Ldblk);
      delka:=4*((delka+3+1)div 4);
      seek(f,filepos(f)+delka);
      end
 else goto Err_Konec;

 BlockRead(f,DataType,sizeof(DataType),Ldblk); {Additional object type}
 BlockRead(f,delka,sizeof(delka),Ldblk); {data size}

 if(z=3) then
   begin
   if(DataType<>miUINT8) then goto Err_Konec;	{unsupported data type}
   p.Create(Header.SizeX,Header.SizeY,24);     {RGB matrix}
   p.typ:='C';
   end
 else
   case DataType of
     miUINT8:begin
       if((Header.StructureFlag and FLAG_LOGICAL)<>0) then
	 p.Create(Header.SizeX,Header.SizeY,1)  {logical matrix}
       else
	 p.Create(Header.SizeX,Header.SizeY,8);{byte matrix}

       Ldblk:=p.x;
       end;
     miUINT16:begin
       p.Create(Header.SizeX,Header.SizeY,16); {word matrix}
       ldblk:=2*longint(p.x);
       end;
     miUINT32:begin
       p.Create(Header.SizeX,Header.SizeY,32); {dword matrix}
       ldblk:=4*longint(p.x);
       end
     else goto Err_Konec;		{unsupported data type}
  end;

 if not(p.valid) then goto Konec;

 if(z=3) then
   begin
    if AlineProc<>nil then
	AlineProc^.InitPassing(3*p.y,'Loading MAT');

   GetMem(data,p.X);
   while(z>=1) do
     begin
     for i:=0 to p.y-1 do
	begin
	Blockread(f,data^,p.X);
	JoinB(p.X,addr(p.data^[i]^.b[3-z]),data,3);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
     dec(z);
     end;
   FreeMem(data,p.X);
   end
 else
   begin
   if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading MAT');

   if(p.planes=1) then
     begin
     GetMem(data,ldblk);
     for i:=0 to p.y-1 do
	begin
	Blockread(f,data^,LdBlk);
	for x:=0 to p.x-1 do
	  begin
	  if datab^.b[x]<>0 then
	    SetPixel(p,x,i,1)
	  else
	    SetPixel(p,x,i,0);
	  end;
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
     FreeMem(data,LdBlk);
     end
   else
     for i:=0 to p.y-1 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
   end;

   Rotate(90,p,AlineProc);
KONEC:
 close(f);
 if IOResult<>0 then LoadPictureMAT:=ErrRdDisk;
end;  {LoadMAT}


Function LoadPictureOKO(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    delka:Longint;
    Ldblk:Word;
    i:Word;
    Header:OkoHeader;
    identif: array[1..15] of char absolute Header;
label KONEC;
begin
 LoadPictureOKO:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureOKO:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
 if Identif<> 'OBR2 Image File' then
		begin
		LoadPictureOKO:=ErrAnother;
		goto KONEC;
		end;
 if(Header.levels=0) then
	begin
	LoadPictureOKO:=ErrData;
	goto KONEC;	{wrong image}
	end;
 p.Create(Header.Rows,Header.Cols,round(ln(Header.levels)/ln(2)));
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading OKO');

 Seek(f,$200);

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 for i:=0 to p.y-1 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
        end;
KONEC:
 close(f);
 if IOResult<>0 then LoadPictureOKO:=ErrRdDisk;
end;  {LoadOKO}


Function LoadPicturePBM(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:text;
    x,y:Word;
    ch:char;
    a:string;
    binary:integer;
    max,i:longint;
label KONEC,NxtRead;
begin
 LoadPicturePBM:=0;
 p.Erase;
 assign2T(f,p.filename^);
 reset(f);
 LoadPicturePBM:=InOutRes;
 if(IOresult<>0) then exit;

 a:=readWord(f,ch);
 if a='P1' then begin
	repeat
	  a:=readWord(f,ch);
	  if a[1]='#' then readln2(f);
	until (a[1]<>'#');

	val(a,x,y);
	y:=readint(f,ch);
	p.create(x,y,1);
	binary:=0;
	end
   else if a='P2' then
	begin
	repeat
	  a:=readWord(f,ch);
	  if a[1]='#' then readln2(f);
	until (a[1]<>'#');

	val(a,x,y);
	y:=readint(f,ch);
	i:=readint(f,ch);
	i:=round(ln(i)/ln(2));
	p.create(x,y,i);
	binary:=0;
	end
  else if a='P3' then
	begin
	repeat
	  a:=readWord(f,ch);
	  if a[1]='#' then readln2(f);
	until (a[1]<>'#');

	val(a,x,y);
	y:=readint(f,ch);
	i:=readint(f,ch);
	p.create(x,y,24);
	p.typ:='C';
	p.planes:=8;
	p.x:=p.x * 3;
	binary:=0;
	end
  else if a='P4' then begin	{binary 2 color format}
	repeat
	  a:=readWord(f,ch);
	  if a[1]='#' then readln2(f);
	until (a[1]<>'#');

	val(a,x,y);
	y:=readint(f,ch);
	p.create(x,y,1);
	binary:=1;
	end
   else if a='P5' then		{gray level binary format}
	begin
	repeat
	  a:=readWord(f,ch);
	  if a[1]='#' then readln2(f);
	until (a[1]<>'#');

	val(a,x,y);
	y:=readint(f,ch);
	i:=readint(f,ch);
	if(i<>255) then goto konec;
	p.create(x,y,8);
	binary:=1;
	end
  else if a='P6' then begin	{binary true color 24bit format}
	repeat
	  a:=readWord(f,ch);
	  if a[1]='#' then readln2(f);
	until (a[1]<>'#');

	val(a,x,y);
	y:=readint(f,ch);
	i:=readint(f,ch);
	if(i<>255) then goto konec;
	p.create(x,y,24);
	p.typ:='C';
	binary:=1;
	end

  else begin
       LoadPicturePBM:=ErrAnother;
       goto konec;
       end;

 if(p.data=nil) then
	goto konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading PBM');
 y:=0;
 x:=0;
 ch:=#0;
 if binary<>0 then {Binary modification}
	begin
	i:=(longint(p.planes)*p.x+7) div 8;
	for x:=0 to p.y-1 do
	    begin
	    BlockreadText(f,p.data^[x]^,i);
	    if p.Planes=1 then
	      NotR(i,p.data^[x]);
	    if AlineProc<>nil then AlineProc^.NextLine;
	    end;
	end
   else begin	  {Text modification}
	while not(eof(f)) do		{load picture data}
	  begin
	     i:=readint(f,ch);
	     SetPixel(p,x,y,i);
	     if IOresult<>0 then goto Konec;
	     inc(x);
	     if ch='.' then readint(f,ch); {dummy read frac part}
NxtRead:     while ch in [' ',#10,#13] do Read(f,ch);   {read spaces to next number}
	     if ch='#' then
		 begin
		 readln2(f);
		 read(f,ch);
		 goto nxtread;
		 end;

	     if ch=';' then readln2(f);
	     if x>=p.x then
		  begin
		  if p.Planes=1 then
		    NotR((longint(p.planes)*p.x+7) div 8,p.data^[y]);
		  inc(y);
		  x:=0;

		  if AlineProc<>nil then AlineProc^.NextLine;
		  if y>=p.y then break;
		  end;
	     if (ch in [#0,';','a'..'z','A'..'Z',#128..#255]) then break;
	  end;
      end;


KONEC:
 if (p.typ='C') then
   begin
   if(binary=0) then
	begin
	p.planes:=24;
	p.x:=p.x div 3;
	end
   end;

 close(f);
 if IOResult<>0 then LoadPicturePBM:=ErrRdDisk;
end;  {LoadPBM}


Function LoadPicturePCX(var p:picture;AlineProc:PAbstractLineProc):integer;
const Mask=$C0;
      MaxCnt=63;
var F:text;
    W,X,Y:Word;
    C,Cnt:byte;
    PcxFile:PcxHeader;
    data:pointer;
    adata:^byte;
    pbuf:Picture;
    Aplane:integer;
    ldblk:word;
label RestOfLast,20;
begin
LoadPicturePCX:=0;
data:=nil;
Pbuf.Init;
  p.Erase;
  assign2T(F,p.FileName^);
  Reset(F);
  LoadPicturePCX:=InOutRes;
  if IOResult<>0 then exit;
  W:=BlockReadText(F,PCXFile,128);
  if PCXFile.Id0<>10 then
		begin
		LoadPicturePCX:=ErrAnother;
		goto 20;			{nekorektni identifikator}
		end;

  p.create(PCXFile.x1-PCXFile.x0+1,PCXFile.y1-PCXFile.y0+1,PCXFile.BitPerPix*PCXFile.NumPlanes);
  ldblk:=(longint(p.planes)*p.X +7) div 8;
  p.typ:='G';
  if p.planes=24 then p.typ:='C';
  if not(p.Valid) then Goto 20;		{obrazek nelze vytvorit}
  if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading PCX');

  Aplane:=PCXFile.NumPlanes;

  if PCXFile.NumPlanes<>1 then
    begin
    Pbuf.Create(p.x,1,PCXFile.BitPerPix);
    data:=pointer(Pbuf.Data^[0]);
    end;

  Y:=0;
  cnt:=0;
  while Y<p.Y do
    begin
    Aplane:=PCXFile.NumPlanes;
    if PCXFile.NumPlanes=1 then data:=pointer(P.Data^[Y]);

    repeat
      adata:=data;
      X:=0;

      if cnt>0 then goto RestOfLast;
      while X<PCXFile.BytesPerLine do
	begin
	W:=BlockReadText(F,C,1);
	Cnt:=1;
	if (C and Mask)=Mask then		 {pridan prefix}
			  begin
			  Cnt:=c and $3F;
			  W:=BlockReadText(F,C,1);
			  end;
RestOfLast:

	while cnt>0 do
	   begin
	   if X>=PCXFile.BytesPerLine then break;  {repeater preteka pres radek}

	   if(x<ldblk) then
	     begin
	     adata^:=C;  {some images have garbage rows bigger than real data}
	     inc(adata);
	     end;
	   inc(X);
	   dec(Cnt);
	   end;


	end;

      if X<>PCXFile.BytesPerLine then
		begin		{load error}
		LoadPicturePCX:=ErrData;
		goto 20;
		end;
					{pridani dalsi bitove roviny}
      if PCXFile.NumPlanes<>1 then
	begin
	if PCXFile.BitPerPix=1 then Join1plane(p,Y,p.planes+1-Aplane,data);
	if (PCXFile.BitPerPix=8)and(p.planes=24) then
		begin		{RGB image}
		if not aplane in [1,2,3] then asm int 3; end;
		JoinB(p.X,addr(p.data^[Y]^.b[3-Aplane]),data,3);
		end;
	end;

    dec(Aplane);		{smycka bitovych rovin}
    until Aplane<1;

  if AlineProc<>nil then AlineProc^.NextLine;
  inc(Y);
  if cnt>0 then	{repeater preteka pres radek}
	   begin		{load error}
	   asm int 3; end;
	   LoadPicturePCX:=ErrData;
	   break;
	   end;
  end;

  if PCXFile.BitPerPix=8 then  {nacteni palety}
       begin
       c:=0;
       blockReadText(F,c,1);
       if (c<>12) then goto 20;
       CreatePalette(p.palette,p.planes);
       if(p.palette<>nil) then
	  begin
	  BlockReadText(F,p.palette^.pal[0],3*256);
	  if GrayPalette(p) then ErasePalette(p.palette)
			    else p.typ:='P';
	  end;
      end;

  if (p.planes=4) or (p.planes=2) then  {presun palety z hlavi‡ky}
	begin
	CreatePalette(p.palette,p.planes);
	move(PCXFile.ColorMap,p.palette^.pal[0],3*p.palette^.colors);
	if GrayPalette(p) then ErasePalette(p.palette)
			  else p.typ:='P';
	end;

20:
  Close(F);

  if IOResult<>0 then LoadPicturePCX:=ErrRdDisk;
  pBuf.Done;
end;  {LoadPCX}


type chunk_layout=record
	Length:   longint;
	CHType:   array[0..3] of char;
	end;

     PNG_IHDR=record
	Width:      longint;
	Height:	    longint;
	BitDepth:   byte;
	ColorType:  byte;
	Compression:byte;
	Filter:	    byte;
	Interlacing:byte;
	end;

Function LoadPicturePNG(var p:picture;AlineProc:PAbstractLineProc):integer;
type Theader=array[0..7] of byte;
     Tinterlace=record
	OffsetX:array[0..6] of byte;
	OffsetY:array[0..6] of byte;
	DeltaX:array[0..6] of byte;
	DeltaY:array[0..6] of byte;
	end;
const PNGheader:Theader=(137,80,78,71,13,10,26,10);
      PNG_Interlace1:Tinterlace=
	(       {1 2 3 4 5 6 7 Interlace Level}
	OffsetX:(0,4,0,2,0,1,0);
	OffsetY:(0,0,4,0,2,0,1);
	DeltaX: (8,8,4,4,2,2,1);
	DeltaY: (8,8,8,4,4,2,2));
var header:Theader;
    ChunkSpec:chunk_layout;
    HeadChunk:PNG_IHDR;
    f:file;
    W:word;
    i,j:integer;
    InterLaceLWL:byte;
    x,y:word;
    ldblk,CurrentFpos:longint;
    PalItem:RGBQuad;
    c,subc,maxsubc,maskc:byte;
label LoadError,PNGError;
begin
 LoadPicturePNG:=0;
 p.Erase;
 assign2(F,p.FileName^);
 Reset(F,1);
 LoadPicturePNG:=InOutRes;
 if IOResult<>0 then exit;

 BlockRead(F,Header,8,W);
 if W<>sizeof(PNGheader) then goto LoadError;
 for i:=0 to 7 do
	if (Header[i]<>PNGheader[i]) then
		begin
LoadError:      LoadPicturePNG:=-1;
		exit;
		end;


 CurrentFpos:=8;
 while not(eof(f)) do
   begin
   BlockRead(F,ChunkSpec,sizeof(ChunkSpec),W);
   ChunkSpec.Length:=longswap(ChunkSpec.Length);

   if(ChunkSpec.CHType='IHDR') then
	begin
	BlockRead(F,HeadChunk,sizeof(HeadChunk),W);
	HeadChunk.Width:=longswap(HeadChunk.Width);
	HeadChunk.Height:=longswap(HeadChunk.Height);
	if(HeadChunk.Compression<>0) then
		begin
PNGError:	LoadPicturePNG:=-1;
		exit;
		end;
	p.Create(HeadChunk.Width,HeadChunk.Height,HeadChunk.BitDepth);
		if p.data=nil then goto PNGError;
	if AlineProc<>nil then
	    AlineProc^.InitPassing(p.y,'Loading PNG');
	c:=0;x:=0;y:=0;
	subc:=8;maskc:=$FF;
	maxsubc:= 0;
	if p.planes=1 then
		begin
		maxsubc:=8;
		maskc:=1;
		end;
	InterLaceLWL:=0;
	ldblk:=(longint(p.planes)*p.x+7) div 8;
	end;


   if(ChunkSpec.CHType='PLTE') then
	begin
	CreatePalette(p.palette,p.planes);
	j:=ChunkSpec.Length div 3;
	if j>(1 shl p.planes) then j:=(1 shl p.planes);
	for i:=0 to j-1 do
		begin
		Blockread(f,p.palette^.pal[i],3);
		end;
	if GrayPalette(p) then ErasePalette(p.palette)
			  else p.typ:='P';
	end;


   if(ChunkSpec.CHType='IDAT') then
	begin
	if not(p.valid) then goto PNGError;


	goto PNGError; {Everything is compressed!!!!!}

	if HeadChunk.Interlacing=0 then
	   while y<p.y do
	     begin
	     Blockread(f,p.data^[y]^,LdBlk);
{	     Blockread(f,w,2);		{docteni do konce radku}
	     inc(y);
	     if AlineProc<>nil then AlineProc^.NextLine;
	     end;


{clrscr;{}

	if HeadChunk.Interlacing=1 then
	   while InterlaceLWL<7 do
	     begin
	     y:=PNG_Interlace1.OffsetY[InterlaceLWL];
	     while y<p.y do
	       begin
	       x:=PNG_Interlace1.OffsetX[InterlaceLWL];
	       while x<p.x do
		  begin
		  if(subc>=maxsubc) then
			begin
			Blockread(f,c,1);
			subc:=1;
			end
		  else begin
		       c:=c shr 1;
		       inc(subc);
		       end;

		  SetPixel(p,x,y,c and maskc);

{		  gotoxy(x+1,y+1);
		  write(c and maskc);
		  gotoxy(70,23);write('x:',x,',y:',y,' ');

		  if readkey=#27 then halt(0);
{		  p.view(nil);readkey;{}


		  inc(x,PNG_Interlace1.DeltaX[InterlaceLWL]);
		  end;
	       inc(y,PNG_Interlace1.DeltaY[InterlaceLWL]);
	       end;
	     inc(InterlaceLWL);
	     end;
	end;


   if(ChunkSpec.CHType='IEND') then break; {END of the PNG file}

   CurrentFpos:=CurrentFpos+sizeof(chunk_layout)+ChunkSpec.Length+4;
   seek(f,CurrentFpos);
   end;

x:=IOresult;

end;


Function LoadPicturePS(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:text;
    x,y,class:Word;
    ch:char;
    Colors:Word;
    pos:longint;
    r,g,b:byte;
    i:longint;
    a:string;
    ptrB:^Byte;
    err:integer;
    RLE_Compressed:boolean;
    ukpalette:Ppalette;

  function ConvertInt:boolean;
  label cti_int;
  begin
    ConvertInt:=true;
cti_int:
    a:=ReadWord(f,ch);	{class type}
    if a[1]='%' then
	begin
	readln2(f);goto cti_int;
	end;
    val(a,i,err);
    if (i<0)or(err<>0) then ConvertInt:=False;
  end;

label CtiX,CtiY,CtiI,CtiZ,CtiZ2,ctiRAS,ctir2,KONEC;
begin
 RLE_Compressed:=false;
 ukpalette:=nil;
 Colors:=0;
 LoadPicturePS:=0;
 p.Erase;
 assign2T(f,p.filename^);
 reset(f);
 LoadPicturePS:=InOutRes;
 if(IOresult<>0) then exit;

 a:=ReadWord(f,ch);
 if copy(a,1,4)<>'%!PS' then goto konec;
 readln2(f);

 while not(eof(f)) do		{auto detect sizes and num of planes}
   begin
   a:=ReadWord(f,ch);
   if a='' then continue;
   if a[1]='%' then
      begin
      if (ch<>#13)and(ch<>#10) then readln2(f);
      continue;
      end;

{   upcases(a);}
    if a[1]='/' then  {ignore definition}
      begin
	if(a='/cmap') then
	  begin
	  pos:=FilePosText(f);
	  if convertint then
	    begin
	    Colors:=i div 3;
	    if(Colors>0) and (Colors<=256) then
	      begin
	      createpalette(UkPalette,round(ln(Colors)/ln(2)));
	      {if i>UkPalette^.colors then x:=UkPalette^.colors;}
	      end;
	    end;
	  SeekText(f,pos);
	  end;

      i:=0;
      repeat
       ch:=GetcharTXT(f);
       if ch='{' then inc(i);
       if ch='}' then dec(i);
       if ch='%' then readln2(f);
       if eof(f) then goto konec;
      until (i=0) and (ch in ['0'..'9','a'..'z','A'..'Z']);
      continue;
      end;

      if( (a='cmap') and (ukPalette<>nil) ) then
      begin
	a:=ReadWord(f,ch);
	if(a='readhexstring') then
	  begin
	  for i:=0 to Colors-1 do
	    begin
	    ukPalette^.pal[i].Red:=  ReadxByte(f);
	    ukPalette^.pal[i].Green:=ReadxByte(f);
	    ukPalette^.pal[i].Blue:= ReadxByte(f);
	    end
	  end;
	continue;
      end;

      if a='DisplayImage' then
	begin
	if not(ConvertInt) then continue; {x translation}
	if not(ConvertInt) then continue; {y translation}
	a:=ReadWord(f,ch);	{x scale}
	a:=ReadWord(f,ch);      {y scale}
	if not(ConvertInt) then continue; {pointsize}
			{read label !!!}
	if not(ConvertInt) then continue; {columns}
	x:=i;
	if not(ConvertInt) then continue; {rows}
	y:=i;
	if not(ConvertInt) then continue; {class type}
	class:=i;
	if not(ConvertInt) then continue; {compression}
	if (i<>1) then continue;{compressed?}
	if(class=0) then
		begin
		i:=24;
		goto ctiRAS;
		end;
	a:=ReadWord(f,ch);      {?????}
	if not(ConvertInt) then continue; {planes}
	goto ctiRAS;
	end;

ctiX: val(a,i,err);
      if i<0 then continue;
      x:=i;
      if err<>0 then continue;

      if not(ConvertInt) then continue;
      y:=i;

      if not(ConvertInt) then continue;
      {planes = i}


ctiZ: a:=ReadWord(f,ch);
      if a[1]='%' then begin;readln2(f);goto ctiZ;end;
      if a[1]<>'[' then continue;
      readln2(f);

ctiZ2:a:=ReadWord(f,ch);
      if a[1]='%' then begin;readln2(f);goto ctiZ;end;
      if a='rlecmapimage' then
		begin
		RLE_Compressed:=True;
		i:=8;
		goto ctiRAS;
		end;

      if a[1]<>'{' then continue;
      readln2(f);

      p.planes:=i;
      while (ch<>#10)and(ch<>#13) do
	begin
	a:=ReadWord(f,ch);
	if a='colorimage' then p.planes:=3*i;
	end;
      goto ctir2;

ctiRAS:p.planes:=i;
ctir2: p.x:=x;
       p.y:=y;

      if(p.planes>64) then
	 begin
	 LoadPicturePS:=ErrData;
	 goto KONEC;
	 end;
      p.Create(p.x,p.y,p.planes);
      {write(p.x,' ',p.y,' ',p.planes,' ');{}
      if not(p.Valid) then goto konec;
      if p.planes>2*i then
		begin
		 p.typ:='C';
		 i:=3*i;
		end;

      i:=(i*p.X+7)div 8 - 1;
      if AlineProc<>nil then
		AlineProc^.InitPassing(p.y,'Loading PS');

      for y:=0 to p.y-1 do
	begin
	ptrb:=pointer(p.data^[y]);
	if RLE_Compressed then
	   begin
	   x:=0;
	   while x<=i do
		begin
		r:=ReadxByte(f);
		if(r<=$80) then
		       begin
		       g:=ReadxByte(f);
		       while(r and $80 = 0) do
			  begin
			  ptrb^:=g;
			  inc(ptrb);inc(x);
			  dec(r);
			  end
		       end
		else while(r>=$80) do
		       begin
		       ptrb^:=ReadxByte(f);
		       inc(ptrb);inc(x);
		       dec(r);
		       end;
		end;
	   end
	else for x:=0 to i do
	   begin
	   ptrb^:=ReadxByte(f);
	   inc(ptrb);
	   if(eof(f)) then goto Konec;
	   end;
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

   break;
   end;

 if p.palette=nil  then p.palette:=UkPalette;
 if p.palette<>nil then p.Typ:='P';
KONEC:
 close(f);
 if IOResult<>0 then LoadPicturePS:=ErrRdDisk;
end;


Function LoadPictureRAS(var p:picture;AlineProc:PAbstractLineProc):integer;
type dlazdT=array[0..1024] of longint;
var f:file;
    delka:Longint;
    Ldblk:Word;
    SkipBlk:Word;
    i:Word;
    Header:RasHeader;
    pal:paletteRAS;
    Mez:Tmez;
    offsety:^dlazdT;
    TilesAcross,TilesDown:Word;
    TilX,TilY:Word;

label KONEC,PalFail,MezFail;
begin
 LoadPictureRAS:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureRAS:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(RasHeader),Ldblk);
 for i:=1 to Sizeof(Header.Name) do if Header.Name[i]<' ' then goto konec;
 if Header.Komprese<>0 then goto konec;
 if (Header.Rows=0) or (Header.Cols=0) then goto Konec;
 if Header.Verze>2 then goto konec;	{neznama verze}

 p.planes:=0;
 if Header.TypSou=0 then p.planes:=1;
 if Header.TypSou in [3,4] then p.planes:=4;
 if Header.TypSou in [1,2] then p.planes:=8;
 if Header.TypSou = 5      then p.planes:=24;
 if Header.TypSou = 6      then p.planes:=16;
 if p.planes=0 then goto KONEC;

 p.create(Header.Cols,Header.Rows,p.Planes);
 if not(p.valid) then goto Konec;{}
 if Header.TypSou = 5      then p.typ:='C';	{True Color}
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading TopoL RAS');


 case Header.Verze of
  0,1:begin
      Seek(f,$200);
      ldblk:=(longint(p.planes)*p.x+7) div 8;
      for i:=0 to p.y-1 do
	     begin
	     Blockread(f,p.data^[i]^,LdBlk);
	     if IOresult<>0 then
		     begin;p.Erase;goto Konec;end;
	     if AlineProc<>nil then AlineProc^.NextLine;
	     end;
      end;
    2:begin
      TilesAcross := (Header.Cols + pred(Header.TileWidth)) div Header.TileWidth;
      TilesDown   := (Header.Rows + pred(Header.TileHeight)) div Header.TileHeight;

      if Header.TileCompression<>0 then begin;p.Erase;goto Konec;end;
      getmem(offsety,TilesAcross*TilesDown*sizeof(longint));

      seek(f,Header.TileOffsets);
      BlockRead(f,offsety^,TilesAcross*TilesDown*sizeof(longint));

      for TilY:=0 to TilesDown-1 do
	for TilX:=0 to TilesAcross-1 do
		begin
		Ldblk := p.x - TilX*Header.TileWidth;
		if(Ldblk>Header.TileWidth) then Ldblk:=Header.TileWidth;
		SkipBlk := ((longint(p.Planes * (Header.TileWidth-Ldblk)+7))) div 8;
		Ldblk := ((longint(p.Planes*Ldblk+7))) div 8;

		seek(f,offsety^[TilY*TilesAcross+ TilX]);
		for i:=0 to Header.TileWidth-1 do
		   begin
		   if i+TilY*Header.TileHeight>p.y then break;
		   Blockread(f,p.data^[i+TilY*Header.TileHeight]^.b[TilX*Header.TileWidth],LdBlk);
		   if IOresult<>0 then
			begin;p.Erase;goto Konec;end;
		   if(SkipBlk>0) then
			seek(f,filepos(f)+SkipBlk);
		   if AlineProc<>nil then AlineProc^.NextLine;
		   end;
		end;

      freemem(offsety,TilesAcross*TilesDown*sizeof(longint));
      end;
   end;
KONEC:
 close(f);
 if IOResult<>0 then
	begin
	LoadPictureRAS:=ErrRdDisk;
	exit;
	end;

 if (p.valid)and(Header.TypSou in [2,4]) then {jeste zbyva nahrani palety}
	begin
	assign2(f,copy(p.filename^,1,length(p.filename^)-3)+'PAL');
	reset(f,1);
	if IOResult<>0 then goto PalFail;
	LdBlk:=0;
	blockRead(f,LdBlk,1); {uvodni informace}
	if IOResult<>0 then goto PalFail;

	CreatePalette(p.palette,p.planes);
	for i:=0 to min(LdBlk,1 shl p.planes)-1 do
		begin
		blockread(f,pal,sizeof(pal));
		p.palette^.pal[pal.Flag].Red  :=pal.Red;
		p.palette^.pal[pal.Flag].Green:=pal.Green;
		p.palette^.pal[pal.Flag].Blue :=pal.Blue;
		end;
PalFail:
	close(f);
	if (GrayPalette(p))or(IOresult<>0) then ErasePalette(p.palette)
					   else p.Typ:='P';
	end;


  if (p.valid)and(Header.TypSou in [1,2,3,4]) then {jeste zbyva nahrani mapovaciho souboru}
	begin
	assign2(f,copy(p.filename^,1,length(p.filename^)-3)+'MEZ');
	reset(f,1);
	blockRead(f,Mez,sizeof(Mez),Ldblk); {uvodni informace}
	close(f);
	if (IOresult<>0) or (LDblk<>256) then goto MezFail;
	Operation1(p,ReTabB,addr(Mez),nil);
	end;
MezFail:
end;


Function LoadPictureRAS_Danger(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    Ldblk:Word;
    i:Word;
    s:searchrec;
    str:string;
label KONEC;
begin
 p.Erase;
 assign2(f,p.filename^);

 LoadPictureRAS_Danger:=0;
 findfirst(p.filename^,ANYFILE,s);
 if doserror<>0 then
    begin
    LoadPictureRAS_Danger:=1;
    exit;
    end;

 if s.size=512*512 then
    begin
    p.create(512,512,8);
    end;
 if s.size=256*256 then
    begin
    p.create(256,256,8);
    end;
 if not(p.valid) then exit;

 reset(f,1);
 LoadPictureRAS_Danger:=InOutRes;
 if(IOresult<>0) then exit;

 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading Plain RAS');

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 for i:=0 to p.y-1 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	if InOutRes<>0 then
           begin
           close(f);
           goto KONEC;
           end;
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
 close(f);

 assign2(f,copy(p.filename^,1,length(p.filename^)-3)+'LUT');
 reset(f,1);
 if IOresult=0 then
    begin
    CreatePalette(p.palette,p.planes);
    blockread(f,p.palette^.pal,p.palette^.Colors*Sizeof(RGB));
    if IOresult<>0 then ErasePalette(p.palette);
    close(f);
    end;

KONEC:
 if IOResult<>0 then p.Erase;
end;

Function LoadPictureSUNRAS(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    Ldblk:Word;
    k,w,i:Word;
    Header:SUNRASHeader;
label KONEC;
begin
 LoadPictureSUNRAS:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureSUNRAS:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
 with header do
    begin
    ras_magic:=longswap(ras_magic);
    ras_width:=longswap(ras_width);
    ras_height:=longswap(ras_height);
    ras_depth:=longswap(ras_depth);
    ras_length:=longswap(ras_length);
    ras_type:=longswap(ras_type);
    ras_maptype:=longswap(ras_maptype);
    ras_maplength:=longswap(ras_maplength);
    end;
 if Header.ras_magic<> $59a66a95 then
		begin
		LoadPictureSUNRAS:=ErrAnother;
		goto KONEC;			{nekorektni identifikator}
		end;

 p.Create(Header.ras_Width,Header.ras_Height,Header.ras_Depth);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading SUNRAS');

 if (Header.ras_maptype<>0)and(Header.ras_maplength<>0) then
	begin
	CreatePalette(p.palette,p.planes);
	w:=(Header.ras_maplength div 3)-1;
	if w<1 shl p.planes then
	   begin
	   for i:=0 to w do Blockread(f,p.palette^.pal[i].Red,1);
	   for i:=0 to w do Blockread(f,p.palette^.pal[i].Green,1);
	   for i:=0 to w do Blockread(f,p.palette^.pal[i].Blue,1);
	   end;
	if GrayPalette(p) then ErasePalette(p.palette)
			  else p.Typ:='P';

	seek(f,sizeof(header)+Header.ras_maplength);
	end;

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 k:=(-ldblk)and $1;
 for i:=0 to p.y-1 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	if i<p.y-1 then Blockread(f,Header.ras_magic,k);  {docteni do konce radku}
	if InOutRes<>0 then goto KONEC;
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
 if p.planes=24 then
	begin
	for i:=p.y-1 downto 0 do RGB_BGR(p.x,p.data^[i]);
	p.typ:='C';
	end;

KONEC:
 close(f);
 if IOResult<>0 then p.Erase;
end;


Function LoadPictureTGA(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    delka:Longint;
    Ldblk:Word;
    i:Word;
    Header:TGAHeader;
    identif: array[1..15] of char absolute Header;
label KONEC;
begin
 LoadPictureTGA:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureTGA:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);

 if ((not(Header.ImageCodeType in [1,2,3])) or (Header.ColorMapType>=2)) then
		begin
		LoadPictureTGA:=ErrAnother;
		goto KONEC;
		end;

 p.Create(Header.Width,Header.Height,Header.ImagePixSize);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading TGA');

 Seek(f,18+Header.IdentifLen);

 if Header.ColorMapType=1 then
   begin
   CreatePalette(p.palette,p.planes);
   if Header.CMapEntrySize = 24 then
	begin				{Pozor Muze se zhroutit pri spatne tabulce}
	BlockRead(f,p.palette^.pal[Header.CMapOrigin],3*Header.CMapLength);
	RGB_BGR(Header.CMapLength,addr(p.palette^.pal[Header.CMapOrigin]));
	end;
   Seek(f,18+Header.IdentifLen+ (Header.CMapEntrySize div 8)*Header.CMapLength);
   end;

 ldblk:=(longint(p.planes)*p.x+7) div 8;

 if Header.ImageCodeType=2 then p.typ:='C';
 for i:=p.y-1 downto 0 do
	begin
	Blockread(f,p.data^[i]^,LdBlk);
	if p.typ='C' then
		begin
		RGB_BGR(p.x,p.data^[i]);
		end;
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
KONEC:
 close(f);
 if IOResult<>0 then p.Erase;
end;


Function LoadPictureTIF(var p:picture;AlineProc:PAbstractLineProc):integer;
type stripArray=array[0..1000] of longint;
var f:file;
    delka:Longint;
    Ldblk:Word;
    i:Word;
    Header:TIFHeader;
    IFD:TIFDirectory;
    EntryCount:Word;
    StripsPtrs:^StripArray;
    PalettePos,NextPtr:longint;

    BitsPerSample,SamplesPerPixel:Word;
    Compression:Word;
    StripOffsets:Longint;
    StripCount:Word;
    RowsPerStrip,PlanarCfg:Word;

    ConvInt:Fconv_i;
    ConvLong:Fconv_l;

label KONEC,PalFail,MezFail;
begin
ConvInt:=nil;ConvLong:=nil;
StripsPtrs:=nil;
PalettePos:=0;
BitsPerSample:=1;
SamplesPerPixel:=1;
Compression:=1;
StripOffsets:=0;
StripCount:=0;
PlanarCfg:=0;
RowsPerStrip:=65535;

 LoadPictureTIF:=0;
 p.Erase;
 p.x:=0;p.y:=0;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureTIF:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);

 if Header.CharId='II' then
	begin
	ConvInt:=LoEnd2CPU;
	ConvLong:=LoEnd2CPUl;
	end;
 if Header.CharId='MM' then
	begin
	ConvInt:=HiEnd2CPU;
	ConvLong:=HiEnd2CPUl;
	end;
 if((@ConvInt=nil)or(@ConvLong=nil)) then goto konec;
 Header.charV:=Convint(Header.charV);
 Header.Pos:=ConvLong(Header.Pos);

 if (Header.CharV<>42) then goto konec; {check of version}
 seek(f,Header.Pos);

 BlockRead(f,EntryCount,sizeof(EntryCount),Ldblk); {process IFD}
 EntryCount:=Convint(EntryCount);
 for i:=1 to EntryCount do
	begin
	BlockRead(f,IFD,sizeof(IFD),Ldblk);
	IFD.Tag:=Convint(IFD.Tag);
	IFD.Field:=Convint(IFD.Field);

	IFD.Long2:=ConvLong(IFD.Long2);
	IFD.Value:=ConvLong(IFD.Value);

	if (IFD.field=3)and(Header.CharId='MM') then
		begin
		if IFD.Long2>=65536 then IFD.Long2:=IFD.Long2 shr 16;
		if IFD.Value>=65536 then IFD.Value:=IFD.Value shr 16;
		end;

	case IFD.Tag of
{		255:;				{SubFileType}
		256:p.X:=ifd.Value;		{ImageWidth   $0100}
		257:p.Y:=ifd.Value;		{ImageLength  $0101}
		258:BitsPerSample:=ifd.Value;   { $102}
		259:Compression:=ifd.Value;	{Compression  $0103}
{		262:;				{PhotometricInterpretation}
{		266:;				{FillOrder}
		273:begin			{StripOffsets $111}
		    StripOffsets:=ifd.Value;
		    StripCount:=ifd.Long2;
		    end;
{		274:;				{Orientation}
		277:SamplesPerPixel:=ifd.Value;	{SamplesPerPixel}
		278:RowsPerStrip:=ifd.Value;	{RowsPerStrip}
{		280:;				{MinSampleValue}
{		281:;				{MaxSampleValue}
{		282:;				{XResolution}
{		283:;				{YResolution}
		284:PlanarCfg:=ifd.Value;	{PlanarConfiguration}
		320:PalettePos:=ifd.Value;	{Palette-color map}
		end;
	end;
 BlockRead(f,NextPtr,sizeof(NextPtr),Ldblk);
 NextPtr:=ConvLong(NextPtr);
 if (StripOffsets=0)or(RowsPerStrip=0) then goto Konec;
 if ((p.y-1) div RowsPerStrip)+1 <> StripCount then goto Konec;

 if SamplesPerPixel=3 then
	begin	{it is a big hack but I really don't know what to do with wrong? BitsPerSample}
	BitsPerSample:=24;
{	asm int 3; end;}
	end;
 p.Create(p.X,p.Y,BitsPerSample);
 if SamplesPerPixel=3 then p.typ:='C';
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading TIF');


 GetMem(StripsPtrs,StripCount*Sizeof(Longint));
 Seek(f,StripOffsets);
 if StripCount>1 then		{vice stripu}
	begin
	Seek(f,StripOffsets);
	BlockRead(f,StripsPtrs^,StripCount*Sizeof(Longint));
	for i:=0 to StripCount-1 do
		StripsPtrs^[i]:=ConvLong(StripsPtrs^[i]);
	end
	else StripsPtrs^[0]:=StripOffsets;
 Seek(f,StripsPtrs^[0]);

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 for i:=0 to p.y-1 do
	begin
	if i mod RowsPerStrip=0 then
		seek(f,StripsPtrs^[i div RowsPerStrip]);
	Blockread(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	if eof(f) or (IOresult<>0) then break;
	end;

 if PalettePos<>0 then		{nacitani palety}
	begin
	seek(f,PalettePos);
	CreatePalette(p.palette,p.planes);
	for i:=0 to (1 shl p.planes)-1 do
		begin
		Blockread(f,Ldblk,2);
		p.palette^.pal[i].Red:=  Hi(LdBlk);
		end;
	for i:=0 to (1 shl p.planes)-1 do
		begin
		Blockread(f,Ldblk,2);
		p.palette^.pal[i].Green:=  Hi(LdBlk);
		end;
	for i:=0 to (1 shl p.planes)-1 do
		begin
		Blockread(f,Ldblk,2);
		p.palette^.pal[i].Blue:=  Hi(LdBlk);
		end;
	if GrayPalette(p) then ErasePalette(p.palette)
			  else p.Typ:='P'
	end;

KONEC:
 close(f);
 if IOResult<>0 then p.Erase;

 if StripsPtrs<>nil then Freemem(StripsPtrs,StripCount*Sizeof(Longint));
end; {LoadTIF}


Function LoadPictureTXT(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:text;
    x,y:Word;
    ch:char;
    max,i:longint;
label KONEC,EndReading;
begin
 LoadPictureTXT:=0;
 p.Erase;
 assign2T(f,p.filename^);
 reset(f);
 LoadPictureTXT:=InOutRes;
 if(IOresult<>0) then exit;

 x:=0;y:=0;
 max:=0;
 i:=0;
 p.x:=0;

 ch:=#0;
 while not(eof(f)) do		{auto detect sizes and num of planes}
   begin
   while not((ch >= '0') and (ch <= '9')) do
	begin               { dojede na pocatek cisla }
	if eof(f) then goto EndReading;
	ch:=GetcharTXT(f);
	if ch in [#0,'a'..'z','A'..'Z',#128..#255] then goto konec; {not a text data}
	end;
   x:=0;
   i:=0;
     repeat
      inc(x);
      i:=readint(f,ch);
      if IOresult<>0 then goto Konec;
      if ch='.' then readint(f,ch); {dummy read frac part}
      if i>MaX then Max:=i;
      if eof(f) then break;
      while ch=' ' do Read(f,ch);   {read spaces to next number}
     until ((ch in [#0,#10,#13,';',':','a'..'z','A'..'Z',#128..#255]) );

   if ch=';' then readln2(f);	{comment}
   if ch in [#0,'a'..'z','A'..'Z',':',#128..#255] then goto konec; {not a text data}
   if x>1 then
	begin
	inc(y);
	if x>p.x then p.x:=x;
	end;
   end;
EndReading:
 p.planes:=1;
 if Max>=    2 then p.planes:=2;
 if Max>=    4 then p.planes:=4;
 if Max>=   16 then p.planes:=8;
 if Max>=  256 then p.planes:=16;
 if Max>=65536 then p.planes:=32;

 if IOResult<>0 then goto Konec;
 close(f);
 reset(f);
 
 p.create(p.x,y,p.planes);
 if not(p.valid) then goto Konec;
 if AlineProc<>nil then
	AlineProc^.InitPassing(p.y,'Loading TXT');

 y:=0;
 ch:=#0;
 while not(eof(f)) do		{load picture data}
   begin
   x:=0;
   while not((ch >= '0') and (ch <= '9')) do
	begin               { dojede na pocatek cisla }
	if eof(f) then goto KONEC;
	ch:=GetcharTXT(f);
	end;
    repeat
      i:=readint(f,ch);
      SetPixel(p,x,y,i);
      if IOresult<>0 then goto Konec;
      inc(x);
      if ch='.' then readint(f,ch); {dummy read frac part}
      if eof(f) then break;
      while ch=' ' do Read(f,ch);   {read spaces to next number}
    until ((ch in [#0,#10,#13,';','a'..'z','A'..'Z',#128..#255]) );

   if ch=';' then readln2(f);
   if x>1 then inc(y);
   end;

KONEC:
 close(f);
 if IOResult<>0 then p.Erase;
end;


Function LoadPictureWPG(var p:picture;AlineProc:PAbstractLineProc):integer;
var f:file;
    delka:Longint;
    Ldblk,Readed:Word;
    x,y,i,SampleSize:Word;
    Pal:Ppalette;
    Header:WpgHeader;
    Rec:WPGRecord;
    Rec2:WPG2Record;
    WPG2bitmapHeader:WPG2BitmapType1;
    bitmapHeader1:_BitmapType1;
    bitmapHeader2:_BitmapType2;
    wpPal:_ColorMapRec;
    palitem:RGBQuad;
    SampleBuffer:array[0..7] of byte;
    CTM:array[0..2,0..2] of real;
    Start2:WPG2Start;

    bbuf:Byte;
    BobrPos:^Byte;
    BObrUpPos:^Byte;
    RunCount:Byte;

    Flags: WORD;

    Procedure InsertByte(b:Byte);
    begin
     if(BObrUpPos<>nil) then
       begin
       BobrPos^:=BObrUpPos^ xor b;
       inc(BObrUpPos);
       end
     else
       BobrPos^:=b;

     inc(BobrPos);
     inc(x);
     if(x>=ldblk) then
	begin
	x:=0;
	BObrUpPos:=nil;
	inc(Y);
	if y>=p.Y then BObrPos:=pointer(p.Data^[0])
		  else BObrPos:=pointer(p.Data^[Y]);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
    end;

    Procedure ClearCTM;
    var x: integer;
	y: integer;
    begin
      for x:=0 to 2 do
	for y:=0 to 2 do
	  if x=y then CTM[x,y]:=1
		 else CTM[x,y]:=0;
    end;

    function LoadWPG2Flags:WORD;
    var Flags:WORD;
	x:longint;
	xW:WORD; DenX:WORD;
    const TPR=1;TRN=2;SKW=4;SCL=8;ROT=$10;OID=$20;LCK=$80;
    begin
      ClearCTM;
      BlockRead(f,Flags,sizeof(Flags),Ldblk);

      if (Flags and LCK) <> 0 then BlockRead(f,x,4,Ldblk);	{Edit lock}
      if (Flags and OID) <> 0 then
	  begin
	    if(Start2.PosSizePrecision=0) then
	      BlockRead(f,x,2,Ldblk)	{ObjectID}
	    else
	      BlockRead(f,x,4,Ldblk);	{ObjectID (Double precision)}
	  end;
      if (Flags and ROT) <> 0 then
	 begin
	 BlockRead(f,x,4,Ldblk);	{Rot Angle}
	 {if(Angle) *Angle=x/65536.0;}
	 end;
      if (Flags and (ROT or SCL)) <> 0 then
	 begin
	 BlockRead(f,x,4,Ldblk);	{Sx*cos()}
	 CTM[0,0] := x / $10000;
	 BlockRead(f,x,4,Ldblk);	{Sy*cos()}
	 CTM[1,1] := x / $10000;
	 end;
      if (Flags and (ROT or SKW)) <> 0 then
	 begin
	 BlockRead(f,x,4,Ldblk);	{Kx*sin()}
	 CTM[1,0] := x / $10000;
	 BlockRead(f,x,4,Ldblk);	{Ky*sin()}
	 CTM[0,1] := x / $10000;
	 end;
{
      if(Flags & TRN)
	 begin
	 Rd_dword(F,(DWORD *)&x); Rd_word(F,&DenX); //Tx
	 if(x>=0) CTM.member(0,2)=(float)x+(float)DenX/0x10000;
	     else CTM.member(0,2)=(float)x-(float)DenX/0x10000;
	 Rd_dword(F,(DWORD *)&x); Rd_word(F,&DenX); //Ty
	 if(x>=0) CTM.member(1,2)=(float)x+(float)DenX/0x10000;
	     else CTM.member(1,2)=(float)x-(float)DenX/0x10000;
	end
      if(Flags & TPR)
	begin
	Rd_word(F,&xW);Rd_word(F,&DenX);	//Px
	CTM.member(2,0)=xW+(float)DenX/0x10000;
	Rd_word(F,&xW);Rd_word(F,&DenX);	//Py
	CTM.member(2,1)=xW+(float)DenX/0x10000;
	end
	}
      LoadWPG2Flags:=Flags;
    end;

label KONEC,LoadImgData;
begin
 Pal:=nil;
 LoadPictureWPG:=0;
 p.Erase;
 assign2(f,p.filename^);
 reset(f,1);
 LoadPictureWPG:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
 if (Header.FileId<>$435057FF)or(Header.ProductType shr 8 <> $16) then
	begin
	LoadPictureWPG:=ErrAnother;
	goto KONEC;
	end;
 if (Header.EncryptKey<>0) then begin;LoadPictureWPG:=ErrVariant; goto KONEC;end;
 BObrUpPos:=nil;

 case Header.FileType of
 1:while not(eof(f)) do		{WPG level 1}
   begin
   Seek(f,Header.DataOffset);
   if(eof(f)) then break;

   Rec.RecordLength:=0;
   Rec.RecType:=0;
   BlockRead(f,Rec,2,readed);
   if (Readed<>2) then break;

   if(Rec.RecordLength=$FF) then BlockRead(f,Rec.RecordLength,2);
   if(Rec.RecordLength and $8000 <> 0) then
	begin
	BlockRead(f,i,2);
	Rec.RecordLength:=((Rec.RecordLength and $7FFF) shl 16) + i;
	end;

   Header.DataOffset:=FilePos(f)+Rec.RecordLength;

   case Rec.RecType of
	 $0B:begin	{bitmapa typ 1}
	     BlockRead(f,bitmapHeader1,sizeof(_BitmapType1),readed);
	     p.create(bitmapHeader1.Width,bitmapHeader1.Height,bitmapHeader1.Depth);
	     bitmapHeader2.RotAngle:=0;

	     goto LoadImgData;
	     end;
	 $0E:begin	{paleta}
	     BlockRead(f,WpPal,sizeof(WpPal),readed);

	     CreatePalette(Pal,round(ln(WpPal.NumOfEntries)/ln(2)));
	     if(Pal=nil) then begin LoadPictureWPG:=ErrMem;goto Konec;end;
	     BlockRead(F,Pal^.pal[WpPal.StartIndex],3*(WpPal.NumOfEntries-WpPal.StartIndex));
	     if InvalidPalette(Pal) then ErasePalette(Pal);
	     end;
	 $14:begin	{bitmapa typ 2}
	     BlockRead(f,bitmapHeader2,sizeof(_BitmapType2),Ldblk);
	     p.create(bitmapHeader2.Width,bitmapHeader2.Height,bitmapHeader2.Depth);

LoadImgData: if not(p.Valid) then goto konec;
	     if AlineProc<>nil then
			AlineProc^.InitPassing(p.y,'Loading WPG');
	     x:=0;
	     y:=0;
	     BObrPos:=pointer(p.Data^[0]);
	     ldblk:=(longint(p.planes)*p.x+7) div 8;

	     while y<p.Y do
	       begin
	       BlockRead(f,bbuf,1,Readed);
	       if Readed<>1 then
			begin
{			p.Erase;}
			goto KONEC;
			end;

	       runcount:=bbuf and $7F;
	       if (BBuf and $80)<>0 then
			begin
			if RunCount<>0 then	{dalsi byte opakuj runcount *}
				begin
				BlockRead(f,bbuf,1,Readed);
				for i:=1 to runcount do InsertByte(bbuf);
				end
			   else begin		{precti dalsi byte jako RunCount; opakuj FF runcount *}
				BlockRead(f,RunCount,1,Readed);
				for i:=1 to runcount do InsertByte($FF);
				end;
			end
		   else begin
			if RunCount<>0 then	{dalsich runcount byte je cteno primo}
				begin
				for i:=1 to runcount do
					begin
					BlockRead(f,bbuf,1,Readed);
					InsertByte(bbuf);
					end;
				end
			   else begin		{opakuj predchozi radek runcount *}
				BlockRead(f,RunCount,1,Readed);
				if x<>0 then
					  asm int 3; end; { dodelat !!!!!!!!}
				for i:=1 to runcount do
					begin
					x:=0;
					inc(Y);
					if y>=p.Y then BObrPos:=pointer(p.Data^[0])
						  else BObrPos:=pointer(p.Data^[Y]);
					if AlineProc<>nil then AlineProc^.NextLine;

					if y<2 then continue;
					if y>p.y then
						goto KONEC;
					move(p.data^[y-2]^,p.data^[y-1]^,ldblk);{}
					end;
				end;
			end;

	       end;

	     if(bitmapHeader2.RotAngle and $8000<>0) then
		begin;Flip('H',p,nil);bitmapHeader2.RotAngle:=bitmapHeader2.RotAngle and $7FFF;end;
	     if(bitmapHeader2.RotAngle and $2000<>0) then
		begin;Flip('V',p,nil);bitmapHeader2.RotAngle:=bitmapHeader2.RotAngle and $DFFF;end;
	     end;
     end;

   end;
2:begin
  ClearCTM;
  Start2.PosSizePrecision:=0;
  while not(eof(f)) do          {WPG level 2}
   begin
   Seek(f,Header.DataOffset);
   if(eof(f)) then break;

   Rec2.RecordLength:=0;
   Rec2.Extension:=0;
   Rec2.RecType:=0;
   Rec2.RecClass:=0;
   BlockRead(f,Rec2,3,readed);
   if (Readed<>3) then break;

   if(Rec2.Extension=$FF) then BlockRead(f,Rec2.Extension,2);
   if(Rec2.Extension and $8000 <> 0) then
	begin
	BlockRead(f,i,2);
	Rec2.Extension:=((Rec2.Extension and $7FFF) shl 16) + i;
	end;

   BlockRead(f,Rec2.RecordLength,1);
   if(Rec2.RecordLength=$FF) then BlockRead(f,Rec2.RecordLength,2);
   if(Rec2.RecordLength and $8000 <> 0) then
	begin
	BlockRead(f,i,2);
	Rec2.RecordLength:=((Rec2.RecordLength and $7FFF) shl 16) + i;
	end;

   Header.DataOffset:=FilePos(f)+Rec2.RecordLength;

   case Rec2.RecType of
	 $01:BlockRead(f,Start2,sizeof(Start2),readed);
	 $0C:begin
	     BlockRead(f,wpPal,4,readed);
	     CreatePalette(Pal,round(ln(WpPal.NumOfEntries)/ln(2)));
	     if(Pal=nil) then continue;
	     for i:=wpPal.StartIndex to Pal^.Colors-1 do
		begin
		Blockread(f,palitem,4);
		pal^.pal[i].Red:=  PalItem.rgbBlue;
		pal^.pal[i].Green:=PalItem.rgbGreen;
		pal^.pal[i].Blue:= PalItem.rgbRed;
		end;
	     end;
	 $0E:begin
	     BlockRead(f,WPG2bitmapHeader,sizeof(WPG2bitmapHeader),readed);
	     case WPG2bitmapHeader.Depth of
	       1:p.create(WPG2bitmapHeader.Width,WPG2bitmapHeader.Height,1);
	       2:p.create(WPG2bitmapHeader.Width,WPG2bitmapHeader.Height,2);
	       3:p.create(WPG2bitmapHeader.Width,WPG2bitmapHeader.Height,4);
	       4:p.create(WPG2bitmapHeader.Width,WPG2bitmapHeader.Height,8);
	       8:begin
		 p.create(WPG2bitmapHeader.Width,WPG2bitmapHeader.Height,24);
		 p.typ:='C';
		 end;
	       end;
	     if(not(p.Valid)) then continue;
	     if AlineProc<>nil then
			AlineProc^.InitPassing(p.y,'Loading WPG l.2');
	     ldblk:=(longint(p.planes)*p.x+7) div 8;

	     if(WPG2bitmapHeader.Compression=0) then
	       for i:=0 to p.y-1 do
		    begin
		    Blockread(f,p.data^[i]^,LdBlk);
		    if AlineProc<>nil then AlineProc^.NextLine;
		    end;
	     if(WPG2bitmapHeader.Compression=1) then
		begin
		SampleSize:=1;

		x:=0;
		y:=0;
		BObrPos:=pointer(p.Data^[Y]);
		ldblk:=(longint(p.planes)*p.x+7) div 8;

		while y<p.Y do  {y=p.Y-1,p.Y-2, .... 0,FFFF}
		  begin
		  BlockRead(f,bbuf,1,Readed);
		  if Readed<>1 then
			   begin
   {			p.Erase;}
			   goto KONEC;
			   end;

		  case bbuf of
		       $7D:begin		{DSZ}
			   BlockRead(f,bbuf,1,Readed);
			   SampleSize:=bbuf;
			   if(SampleSize>8) then SampleSize:=8;
			   end;
		       $7E:begin			{XOR}
			   if(y=0) then
			      writeln('\nWPG token XOR on the first line is not supported, please report!')
			   else
			      BObrUpPos := pointer(p.Data^[y-1])
			   end;
		       $7F:begin		{BLK}
			   BlockRead(f,runcount,1,Readed);
			   for i:=1 to SampleSize*(runcount+1) do
				   begin
				   InsertByte(0);
				   end;
			   end;
		       $FD:begin		{EXT}
			   BlockRead(f,runcount,1,Readed);
			   for i:=0 to runcount do
			     for bbuf:=0 to SampleSize-1 do
			       InsertByte(SampleBuffer[bbuf]);
			   end;
		       $FE:begin			{RST}
			   BlockRead(f,RunCount,1,Readed);
			   if x<>0 then
					asm int 3; end; { dodelat !!!!!!!!}
			   for i:=1 to runcount do
				begin
				x:=0;
				inc(Y);
				if y>=p.Y then BObrPos:=pointer(p.Data^[0])
					  else BObrPos:=pointer(p.Data^[Y]);
				if AlineProc<>nil then AlineProc^.NextLine;

				if y<2 then continue;
				if y>p.y then
					goto KONEC;
				move(p.data^[y-2]^,p.data^[y-1]^,ldblk);{}
				end;
			   end;
		       $FF:begin		{WHT}
			   BlockRead(f,runcount,1,Readed);
			   for i:=1 to SampleSize*(runcount+1) do
				   begin
				   InsertByte($FF);
				   end;
			   end;
		  else
		  runcount:=bbuf and $7F;
		  if (BBuf and $80)<>0 then	{NRP}
			   begin	{dalsi SmapleSize opakuj (runcount+1)*}
			   for i:=0 to SampleSize-1 do
				BlockRead(f,SampleBuffer[i],1,Readed);
			   for i:=0 to runcount do
			     for bbuf:=0 to SampleSize-1 do
			       InsertByte(SampleBuffer[bbuf]);
			   end
						{REP}
		      else begin {dalsich runcount*SampleSize byte je cteno primo}
			   for i:=1 to SampleSize*(runcount+1) do
				   begin
				   BlockRead(f,bbuf,1,Readed);
				   InsertByte(bbuf);
				   end;
			   end;
		      end;
		  end;
	       end;
	     if CTM[0,0]<0 then Flip('H',p,AlineProc);
	     if CTM[1,1]<0 then Flip('V',p,AlineProc);
	     end;

	 $1B:begin
	     Flags:=LoadWPG2Flags;
	     end;

	 $02:goto KONEC;	{End of WPG l2}
       end;

   end
  end

  else LoadPictureWPG:=ErrVariant;
  end;

 if not(p.valid) then LoadPictureWPG:=ErrVariant;
KONEC:
 if Pal<>nil then
	begin
	p.Palette:=pal;
	pal:=nil;
	if GrayPalette(p) then ErasePalette(p.palette)
			  else p.Typ:='P';
	end;
 close(f);
 if IOResult<>0 then p.Erase;
end;




begin
end.

algoritmy: 2D Schlesinger
	   Exponencialni kod
	   1D Sch okraje
	   3D Schlesinger pro sedotonove obrazky
	   LZW casti kodu

zatim neimplementovano:
	   plovouci n
	   LZW^2
	   LZW^2 specialni kruhovy kod (bomba!)


